lib/CPAN.pm

   1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
   2 use strict;
   3 package CPAN;
   4 $CPAN::VERSION = '1.9204';
   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 CPAN::DeferedCode;
  13 use Carp ();
  14 use Config ();
  15 use Cwd ();
  16 use DirHandle ();
  17 use Exporter ();
  18 use ExtUtils::MakeMaker qw(prompt); # for some unknown reason,
  19                                     # 5.005_04 does not work without
  20                                     # this
  21 use File::Basename ();
  22 use File::Copy ();
  23 use File::Find;
  24 use File::Path ();
  25 use File::Spec ();
  26 use FileHandle ();
  27 use Fcntl qw(:flock);
  28 use Safe ();
  29 use Sys::Hostname qw(hostname);
  30 use Text::ParseWords ();
  31 use Text::Wrap ();
  32
  33 sub find_perl ();
  34
  35 # we need to run chdir all over and we would get at wrong libraries
  36 # there
  37 BEGIN {
  38     if (File::Spec->can("rel2abs")) {
  39         for my $inc (@INC) {
  40             $inc = File::Spec->rel2abs($inc) unless ref $inc;
  41         }
  42     }
  43 }
  44 no lib ".";
  45
  46 require Mac::BuildTools if $^O eq 'MacOS';
  47 $ENV{PERL5_CPAN_IS_RUNNING}=$$;
  48 $ENV{PERL5_CPANPLUS_IS_RUNNING}=$$; # https://rt.cpan.org/Ticket/Display.html?id=23735
  49
  50 END { $CPAN::End++; &cleanup; }
  51
  52 $CPAN::Signal ||= 0;
  53 $CPAN::Frontend ||= "CPAN::Shell";
  54 unless (@CPAN::Defaultsites) {
  55     @CPAN::Defaultsites = map {
  56         CPAN::URL->new(TEXT => $_, FROM => "DEF")
  57     }
  58         "http://www.perl.org/CPAN/",
  59             "ftp://ftp.perl.org/pub/CPAN/";
  60 }
  61 # $CPAN::iCwd (i for initial) is going to be initialized during find_perl
  62 $CPAN::Perl ||= CPAN::find_perl();
  63 $CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?";
  64 $CPAN::Defaultrecent ||= "http://search.cpan.org/uploads.rdf";
  65 $CPAN::Defaultrecent ||= "http://cpan.uwinnipeg.ca/htdocs/cpan.xml";
  66
  67 # our globals are getting a mess
  68 use vars qw(
  69             $AUTOLOAD
  70             $Be_Silent
  71             $CONFIG_DIRTY
  72             $Defaultdocs
  73             $Echo_readline
  74             $Frontend
  75             $GOTOSHELL
  76             $HAS_USABLE
  77             $Have_warned
  78             $MAX_RECURSION
  79             $META
  80             $RUN_DEGRADED
  81             $Signal
  82             $SQLite
  83             $Suppress_readline
  84             $VERSION
  85             $autoload_recursion
  86             $term
  87             @Defaultsites
  88             @EXPORT
  89            );
  90
  91 $MAX_RECURSION = 32;
  92
  93 @CPAN::ISA = qw(CPAN::Debug Exporter);
  94
  95 # note that these functions live in CPAN::Shell and get executed via
  96 # AUTOLOAD when called directly
  97 @EXPORT = qw(
  98              autobundle
  99              bundle
 100              clean
 101              cvs_import
 102              expand
 103              force
 104              fforce
 105              get
 106              install
 107              install_tested
 108              is_tested
 109              make
 110              mkmyconfig
 111              notest
 112              perldoc
 113              readme
 114              recent
 115              recompile
 116              report
 117              shell
 118              smoke
 119              test
 120              upgrade
 121             );
 122
 123 sub soft_chdir_with_alternatives ($);
 124
 125 {
 126     $autoload_recursion ||= 0;
 127
 128     #-> sub CPAN::AUTOLOAD ;
 129     sub AUTOLOAD {
 130         $autoload_recursion++;
 131         my($l) = $AUTOLOAD;
 132         $l =~ s/.*:://;
 133         if ($CPAN::Signal) {
 134             warn "Refusing to autoload '$l' while signal pending";
 135             $autoload_recursion--;
 136             return;
 137         }
 138         if ($autoload_recursion > 1) {
 139             my $fullcommand = join " ", map { "'$_'" } $l, @_;
 140             warn "Refusing to autoload $fullcommand in recursion\n";
 141             $autoload_recursion--;
 142             return;
 143         }
 144         my(%export);
 145         @export{@EXPORT} = '';
 146         CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 147         if (exists $export{$l}) {
 148             CPAN::Shell->$l(@_);
 149         } else {
 150             die(qq{Unknown CPAN command "$AUTOLOAD". }.
 151                 qq{Type ? for help.\n});
 152         }
 153         $autoload_recursion--;
 154     }
 155 }
 156
 157 #-> sub CPAN::shell ;
 158 sub shell {
 159     my($self) = @_;
 160     $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
 161     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 162
 163     my $oprompt = shift || CPAN::Prompt->new;
 164     my $prompt = $oprompt;
 165     my $commandline = shift || "";
 166     $CPAN::CurrentCommandId ||= 1;
 167
 168     local($^W) = 1;
 169     unless ($Suppress_readline) {
 170         require Term::ReadLine;
 171         if (! $term
 172             or
 173             $term->ReadLine eq "Term::ReadLine::Stub"
 174            ) {
 175             $term = Term::ReadLine->new('CPAN Monitor');
 176         }
 177         if ($term->ReadLine eq "Term::ReadLine::Gnu") {
 178             my $attribs = $term->Attribs;
 179             $attribs->{attempted_completion_function} = sub {
 180                 &CPAN::Complete::gnu_cpl;
 181             }
 182         } else {
 183             $readline::rl_completion_function =
 184                 $readline::rl_completion_function = 'CPAN::Complete::cpl';
 185         }
 186         if (my $histfile = $CPAN::Config->{'histfile'}) {{
 187             unless ($term->can("AddHistory")) {
 188                 $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
 189                 last;
 190             }
 191             $META->readhist($term,$histfile);
 192         }}
 193         for ($CPAN::Config->{term_ornaments}) { # alias
 194             local $Term::ReadLine::termcap_nowarn = 1;
 195             $term->ornaments($_) if defined;
 196         }
 197         # $term->OUT is autoflushed anyway
 198         my $odef = select STDERR;
 199         $| = 1;
 200         select STDOUT;
 201         $| = 1;
 202         select $odef;
 203     }
 204
 205     $META->checklock();
 206     my @cwd = grep { defined $_ and length $_ }
 207         CPAN::anycwd(),
 208               File::Spec->can("tmpdir") ? File::Spec->tmpdir() : (),
 209                     File::Spec->rootdir();
 210     my $try_detect_readline;
 211     $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
 212     unless ($CPAN::Config->{inhibit_startup_message}) {
 213         my $rl_avail = $Suppress_readline ? "suppressed" :
 214             ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
 215                 "available (maybe install Bundle::CPAN or Bundle::CPANxxl?)";
 216         $CPAN::Frontend->myprint(
 217                                  sprintf qq{
 218 cpan shell -- CPAN exploration and modules installation (v%s)
 219 ReadLine support %s
 220
 221 },
 222                                  $CPAN::VERSION,
 223                                  $rl_avail
 224                                 )
 225     }
 226     my($continuation) = "";
 227     my $last_term_ornaments;
 228   SHELLCOMMAND: while () {
 229         if ($Suppress_readline) {
 230             if ($Echo_readline) {
 231                 $|=1;
 232             }
 233             print $prompt;
 234             last SHELLCOMMAND unless defined ($_ = <> );
 235             if ($Echo_readline) {
 236                 # backdoor: I could not find a way to record sessions
 237                 print $_;
 238             }
 239             chomp;
 240         } else {
 241             last SHELLCOMMAND unless
 242                 defined ($_ = $term->readline($prompt, $commandline));
 243         }
 244         $_ = "$continuation$_" if $continuation;
 245         s/^\s+//;
 246         next SHELLCOMMAND if /^$/;
 247         s/^\s*\?\s*/help /;
 248         if (/^(?:q(?:uit)?|bye|exit)$/i) {
 249             last SHELLCOMMAND;
 250         } elsif (s/\\$//s) {
 251             chomp;
 252             $continuation = $_;
 253             $prompt = "    > ";
 254         } elsif (/^\!/) {
 255             s/^\!//;
 256             my($eval) = $_;
 257             package CPAN::Eval;
 258             use strict;
 259             use vars qw($import_done);
 260             CPAN->import(':DEFAULT') unless $import_done++;
 261             CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
 262             eval($eval);
 263             warn $@ if $@;
 264             $continuation = "";
 265             $prompt = $oprompt;
 266         } elsif (/./) {
 267             my(@line);
 268             eval { @line = Text::ParseWords::shellwords($_) };
 269             warn($@), next SHELLCOMMAND if $@;
 270             warn("Text::Parsewords could not parse the line [$_]"),
 271                 next SHELLCOMMAND unless @line;
 272             $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
 273             my $command = shift @line;
 274             eval { CPAN::Shell->$command(@line) };
 275             if ($@) {
 276                 my $err = "$@";
 277                 if ($err =~ /\S/) {
 278                     require Carp;
 279                     require Dumpvalue;
 280                     my $dv = Dumpvalue->new();
 281                     Carp::cluck(sprintf "Catching error: %s", $dv->stringify($err));
 282                 }
 283             }
 284             if ($command =~ /^(
 285                              # classic commands
 286                              make
 287                              |test
 288                              |install
 289                              |clean
 290
 291                              # pragmas for classic commands
 292                              |ff?orce
 293                              |notest
 294
 295                              # compounds
 296                              |report
 297                              |smoke
 298                              |upgrade
 299                             )$/x) {
 300                 # only commands that tell us something about failed distros
 301                 CPAN::Shell->failed($CPAN::CurrentCommandId,1);
 302             }
 303             soft_chdir_with_alternatives(\@cwd);
 304             $CPAN::Frontend->myprint("\n");
 305             $continuation = "";
 306             $CPAN::CurrentCommandId++;
 307             $prompt = $oprompt;
 308         }
 309     } continue {
 310         $commandline = ""; # I do want to be able to pass a default to
 311                            # shell, but on the second command I see no
 312                            # use in that
 313         $Signal=0;
 314         CPAN::Queue->nullify_queue;
 315         if ($try_detect_readline) {
 316             if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
 317                 ||
 318                 $CPAN::META->has_inst("Term::ReadLine::Perl")
 319             ) {
 320                 delete $INC{"Term/ReadLine.pm"};
 321                 my $redef = 0;
 322                 local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
 323                 require Term::ReadLine;
 324                 $CPAN::Frontend->myprint("\n$redef subroutines in ".
 325                                          "Term::ReadLine redefined\n");
 326                 $GOTOSHELL = 1;
 327             }
 328         }
 329         if ($term and $term->can("ornaments")) {
 330             for ($CPAN::Config->{term_ornaments}) { # alias
 331                 if (defined $_) {
 332                     if (not defined $last_term_ornaments
 333                         or $_ != $last_term_ornaments
 334                     ) {
 335                         local $Term::ReadLine::termcap_nowarn = 1;
 336                         $term->ornaments($_);
 337                         $last_term_ornaments = $_;
 338                     }
 339                 } else {
 340                     undef $last_term_ornaments;
 341                 }
 342             }
 343         }
 344         for my $class (qw(Module Distribution)) {
 345             # again unsafe meta access?
 346             for my $dm (keys %{$CPAN::META->{readwrite}{"CPAN::$class"}}) {
 347                 next unless $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
 348                 CPAN->debug("BUG: $class '$dm' was in command state, resetting");
 349                 delete $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
 350             }
 351         }
 352         if ($GOTOSHELL) {
 353             $GOTOSHELL = 0; # not too often
 354             $META->savehist if $CPAN::term && $CPAN::term->can("GetHistory");
 355             @_ = ($oprompt,"");
 356             goto &shell;
 357         }
 358     }
 359     soft_chdir_with_alternatives(\@cwd);
 360 }
 361
 362 sub soft_chdir_with_alternatives ($) {
 363     my($cwd) = @_;
 364     unless (@$cwd) {
 365         my $root = File::Spec->rootdir();
 366         $CPAN::Frontend->mywarn(qq{Warning: no good directory to chdir to!
 367 Trying '$root' as temporary haven.
 368 });
 369         push @$cwd, $root;
 370     }
 371     while () {
 372         if (chdir $cwd->[0]) {
 373             return;
 374         } else {
 375             if (@$cwd>1) {
 376                 $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $!
 377 Trying to chdir to "$cwd->[1]" instead.
 378 });
 379                 shift @$cwd;
 380             } else {
 381                 $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!});
 382             }
 383         }
 384     }
 385 }
 386
 387 sub _flock {
 388     my($fh,$mode) = @_;
 389     if ($Config::Config{d_flock}) {
 390         return flock $fh, $mode;
 391     } elsif (!$Have_warned->{"d_flock"}++) {
 392         $CPAN::Frontend->mywarn("Your OS does not support locking; continuing and ignoring all locking issues\n");
 393         $CPAN::Frontend->mysleep(5);
 394         return 1;
 395     } else {
 396         return 1;
 397     }
 398 }
 399
 400 sub _yaml_module () {
 401     my $yaml_module = $CPAN::Config->{yaml_module} || "YAML";
 402     if (
 403         $yaml_module ne "YAML"
 404         &&
 405         !$CPAN::META->has_inst($yaml_module)
 406        ) {
 407         # $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back to 'YAML'\n");
 408         $yaml_module = "YAML";
 409     }
 410     if ($yaml_module eq "YAML"
 411         &&
 412         $CPAN::META->has_inst($yaml_module)
 413         &&
 414         $YAML::VERSION < 0.60
 415         &&
 416         !$Have_warned->{"YAML"}++
 417        ) {
 418         $CPAN::Frontend->mywarn("Warning: YAML version '$YAML::VERSION' is too low, please upgrade!\n".
 419                                 "I'll continue but problems are *very* likely to happen.\n"
 420                                );
 421         $CPAN::Frontend->mysleep(5);
 422     }
 423     return $yaml_module;
 424 }
 425
 426 # CPAN::_yaml_loadfile
 427 sub _yaml_loadfile {
 428     my($self,$local_file) = @_;
 429     return +[] unless -s $local_file;
 430     my $yaml_module = _yaml_module;
 431     if ($CPAN::META->has_inst($yaml_module)) {
 432         # temporarly enable yaml code deserialisation
 433         no strict 'refs';
 434         # 5.6.2 could not do the local() with the reference
 435         local $YAML::LoadCode;
 436         local $YAML::Syck::LoadCode;
 437         ${ "$yaml_module\::LoadCode" } = $CPAN::Config->{yaml_load_code} || 0;
 438
 439         my $code;
 440         if ($code = UNIVERSAL::can($yaml_module, "LoadFile")) {
 441             my @yaml;
 442             eval { @yaml = $code->($local_file); };
 443             if ($@) {
 444                 # this shall not be done by the frontend
 445                 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
 446             }
 447             return \@yaml;
 448         } elsif ($code = UNIVERSAL::can($yaml_module, "Load")) {
 449             local *FH;
 450             open FH, $local_file or die "Could not open '$local_file': $!";
 451             local $/;
 452             my $ystream = <FH>;
 453             my @yaml;
 454             eval { @yaml = $code->($ystream); };
 455             if ($@) {
 456                 # this shall not be done by the frontend
 457                 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
 458             }
 459             return \@yaml;
 460         }
 461     } else {
 462         # this shall not be done by the frontend
 463         die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "parse");
 464     }
 465     return +[];
 466 }
 467
 468 # CPAN::_yaml_dumpfile
 469 sub _yaml_dumpfile {
 470     my($self,$local_file,@what) = @_;
 471     my $yaml_module = _yaml_module;
 472     if ($CPAN::META->has_inst($yaml_module)) {
 473         my $code;
 474         if (UNIVERSAL::isa($local_file, "FileHandle")) {
 475             $code = UNIVERSAL::can($yaml_module, "Dump");
 476             eval { print $local_file $code->(@what) };
 477         } elsif ($code = UNIVERSAL::can($yaml_module, "DumpFile")) {
 478             eval { $code->($local_file,@what); };
 479         } elsif ($code = UNIVERSAL::can($yaml_module, "Dump")) {
 480             local *FH;
 481             open FH, ">$local_file" or die "Could not open '$local_file': $!";
 482             print FH $code->(@what);
 483         }
 484         if ($@) {
 485             die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"dump",$@);
 486         }
 487     } else {
 488         if (UNIVERSAL::isa($local_file, "FileHandle")) {
 489             # I think this case does not justify a warning at all
 490         } else {
 491             die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "dump");
 492         }
 493     }
 494 }
 495
 496 sub _init_sqlite () {
 497     unless ($CPAN::META->has_inst("CPAN::SQLite")) {
 498         $CPAN::Frontend->mywarn(qq{CPAN::SQLite not installed, trying to work without\n})
 499             unless $Have_warned->{"CPAN::SQLite"}++;
 500         return;
 501     }
 502     require CPAN::SQLite::META; # not needed since CVS version of 2006-12-17
 503     $CPAN::SQLite ||= CPAN::SQLite::META->new($CPAN::META);
 504 }
 505
 506 {
 507     my $negative_cache = {};
 508     sub _sqlite_running {
 509         if ($negative_cache->{time} && time < $negative_cache->{time} + 60) {
 510             # need to cache the result, otherwise too slow
 511             return $negative_cache->{fact};
 512         } else {
 513             $negative_cache = {}; # reset
 514         }
 515         my $ret = $CPAN::Config->{use_sqlite} && ($CPAN::SQLite || _init_sqlite());
 516         return $ret if $ret; # fast anyway
 517         $negative_cache->{time} = time;
 518         return $negative_cache->{fact} = $ret;
 519     }
 520 }
 521
 522 package CPAN::CacheMgr;
 523 use strict;
 524 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
 525 use File::Find;
 526
 527 package CPAN::FTP;
 528 use strict;
 529 use Fcntl qw(:flock);
 530 use vars qw($connect_to_internet_ok $Ua $Thesite $ThesiteURL $Themethod);
 531 @CPAN::FTP::ISA = qw(CPAN::Debug);
 532
 533 package CPAN::LWP::UserAgent;
 534 use strict;
 535 use vars qw(@ISA $USER $PASSWD $SETUPDONE);
 536 # we delay requiring LWP::UserAgent and setting up inheritance until we need it
 537
 538 package CPAN::Complete;
 539 use strict;
 540 @CPAN::Complete::ISA = qw(CPAN::Debug);
 541 # Q: where is the "How do I add a new command" HOWTO?
 542 # A: svn diff -r 1048:1049 where andk added the report command
 543 @CPAN::Complete::COMMANDS = sort qw(
 544                                     ? ! a b d h i m o q r u
 545                                     autobundle
 546                                     bye
 547                                     clean
 548                                     cvs_import
 549                                     dump
 550                                     exit
 551                                     failed
 552                                     force
 553                                     fforce
 554                                     hosts
 555                                     install
 556                                     install_tested
 557                                     is_tested
 558                                     look
 559                                     ls
 560                                     make
 561                                     mkmyconfig
 562                                     notest
 563                                     perldoc
 564                                     quit
 565                                     readme
 566                                     recent
 567                                     recompile
 568                                     reload
 569                                     report
 570                                     reports
 571                                     scripts
 572                                     smoke
 573                                     test
 574                                     upgrade
 575 );
 576
 577 package CPAN::Index;
 578 use strict;
 579 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED);
 580 @CPAN::Index::ISA = qw(CPAN::Debug);
 581 $LAST_TIME ||= 0;
 582 $DATE_OF_03 ||= 0;
 583 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
 584 sub PROTOCOL { 2.0 }
 585
 586 package CPAN::InfoObj;
 587 use strict;
 588 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
 589
 590 package CPAN::Author;
 591 use strict;
 592 @CPAN::Author::ISA = qw(CPAN::InfoObj);
 593
 594 package CPAN::Distribution;
 595 use strict;
 596 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
 597
 598 package CPAN::Bundle;
 599 use strict;
 600 @CPAN::Bundle::ISA = qw(CPAN::Module);
 601
 602 package CPAN::Module;
 603 use strict;
 604 @CPAN::Module::ISA = qw(CPAN::InfoObj);
 605
 606 package CPAN::Exception::RecursiveDependency;
 607 use strict;
 608 use overload '""' => "as_string";
 609
 610 # a module sees its distribution (no version)
 611 # a distribution sees its prereqs (which are module names) (usually with versions)
 612 # a bundle sees its module names and/or its distributions (no version)
 613
 614 sub new {
 615     my($class) = shift;
 616     my($deps) = shift;
 617     my (@deps,%seen,$loop_starts_with);
 618   DCHAIN: for my $dep (@$deps) {
 619         push @deps, {name => $dep, display_as => $dep};
 620         if ($seen{$dep}++) {
 621             $loop_starts_with = $dep;
 622             last DCHAIN;
 623         }
 624     }
 625     my $in_loop = 0;
 626     for my $i (0..$#deps) {
 627         my $x = $deps[$i]{name};
 628         $in_loop ||= $x eq $loop_starts_with;
 629         my $xo = CPAN::Shell->expandany($x) or next;
 630         if ($xo->isa("CPAN::Module")) {
 631             my $have = $xo->inst_version || "N/A";
 632             my($want,$d,$want_type);
 633             if ($i>0 and $d = $deps[$i-1]{name}) {
 634                 my $do = CPAN::Shell->expandany($d);
 635                 $want = $do->{prereq_pm}{requires}{$x};
 636                 if (defined $want) {
 637                     $want_type = "requires: ";
 638                 } else {
 639                     $want = $do->{prereq_pm}{build_requires}{$x};
 640                     if (defined $want) {
 641                         $want_type = "build_requires: ";
 642                     } else {
 643                         $want_type = "unknown status";
 644                         $want = "???";
 645                     }
 646                 }
 647             } else {
 648                 $want = $xo->cpan_version;
 649                 $want_type = "want: ";
 650             }
 651             $deps[$i]{have} = $have;
 652             $deps[$i]{want_type} = $want_type;
 653             $deps[$i]{want} = $want;
 654             $deps[$i]{display_as} = "$x (have: $have; $want_type$want)";
 655         } elsif ($xo->isa("CPAN::Distribution")) {
 656             $deps[$i]{display_as} = $xo->pretty_id;
 657             if ($in_loop) {
 658                 $xo->{make} = CPAN::Distrostatus->new("NO cannot resolve circular dependency");
 659             } else {
 660                 $xo->{make} = CPAN::Distrostatus->new("NO one dependency ($loop_starts_with) is a circular dependency");
 661             }
 662             $xo->store_persistent_state; # otherwise I will not reach
 663                                          # all involved parties for
 664                                          # the next session
 665         }
 666     }
 667     bless { deps => \@deps }, $class;
 668 }
 669
 670 sub as_string {
 671     my($self) = shift;
 672     my $ret = "\nRecursive dependency detected:\n    ";
 673     $ret .= join("\n => ", map {$_->{display_as}} @{$self->{deps}});
 674     $ret .= ".\nCannot resolve.\n";
 675     $ret;
 676 }
 677
 678 package CPAN::Exception::yaml_not_installed;
 679 use strict;
 680 use overload '""' => "as_string";
 681
 682 sub new {
 683     my($class,$module,$file,$during) = @_;
 684     bless { module => $module, file => $file, during => $during }, $class;
 685 }
 686
 687 sub as_string {
 688     my($self) = shift;
 689     "'$self->{module}' not installed, cannot $self->{during} '$self->{file}'\n";
 690 }
 691
 692 package CPAN::Exception::yaml_process_error;
 693 use strict;
 694 use overload '""' => "as_string";
 695
 696 sub new {
 697     my($class,$module,$file,$during,$error) = @_;
 698     bless { module => $module,
 699             file => $file,
 700             during => $during,
 701             error => $error }, $class;
 702 }
 703
 704 sub as_string {
 705     my($self) = shift;
 706     if ($self->{during}) {
 707         if ($self->{file}) {
 708             if ($self->{module}) {
 709                 if ($self->{error}) {
 710                     return "Alert: While trying to '$self->{during}' YAML file\n".
 711                         " '$self->{file}'\n".
 712                             "with '$self->{module}' the following error was encountered:\n".
 713                                 "  $self->{error}\n";
 714                 } else {
 715                     return "Alert: While trying to '$self->{during}' YAML file\n".
 716                         " '$self->{file}'\n".
 717                             "with '$self->{module}' some unknown error was encountered\n";
 718                 }
 719             } else {
 720                 return "Alert: While trying to '$self->{during}' YAML file\n".
 721                     " '$self->{file}'\n".
 722                         "some unknown error was encountered\n";
 723             }
 724         } else {
 725             return "Alert: While trying to '$self->{during}' some YAML file\n".
 726                     "some unknown error was encountered\n";
 727         }
 728     } else {
 729         return "Alert: unknown error encountered\n";
 730     }
 731 }
 732
 733 package CPAN::Prompt; use overload '""' => "as_string";
 734 use vars qw($prompt);
 735 $prompt = "cpan> ";
 736 $CPAN::CurrentCommandId ||= 0;
 737 sub new {
 738     bless {}, shift;
 739 }
 740 sub as_string {
 741     my $word = "cpan";
 742     unless ($CPAN::META->{LOCK}) {
 743         $word = "nolock_cpan";
 744     }
 745     if ($CPAN::Config->{commandnumber_in_prompt}) {
 746         sprintf "$word\[%d]> ", $CPAN::CurrentCommandId;
 747     } else {
 748         "$word> ";
 749     }
 750 }
 751
 752 package CPAN::URL; use overload '""' => "as_string", fallback => 1;
 753 # accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist),
 754 # planned are things like age or quality
 755 sub new {
 756     my($class,%args) = @_;
 757     bless {
 758            %args
 759           }, $class;
 760 }
 761 sub as_string {
 762     my($self) = @_;
 763     $self->text;
 764 }
 765 sub text {
 766     my($self,$set) = @_;
 767     if (defined $set) {
 768         $self->{TEXT} = $set;
 769     }
 770     $self->{TEXT};
 771 }
 772
 773 package CPAN::Distrostatus;
 774 use overload '""' => "as_string",
 775     fallback => 1;
 776 sub new {
 777     my($class,$arg) = @_;
 778     bless {
 779            TEXT => $arg,
 780            FAILED => substr($arg,0,2) eq "NO",
 781            COMMANDID => $CPAN::CurrentCommandId,
 782            TIME => time,
 783           }, $class;
 784 }
 785 sub commandid { shift->{COMMANDID} }
 786 sub failed { shift->{FAILED} }
 787 sub text {
 788     my($self,$set) = @_;
 789     if (defined $set) {
 790         $self->{TEXT} = $set;
 791     }
 792     $self->{TEXT};
 793 }
 794 sub as_string {
 795     my($self) = @_;
 796     $self->text;
 797 }
 798
 799 package CPAN::Shell;
 800 use strict;
 801 use vars qw(
 802             $ADVANCED_QUERY
 803             $AUTOLOAD
 804             $COLOR_REGISTERED
 805             $Help
 806             $autoload_recursion
 807             $reload
 808             @ISA
 809            );
 810 @CPAN::Shell::ISA = qw(CPAN::Debug);
 811 $COLOR_REGISTERED ||= 0;
 812 $Help = {
 813          '?' => \"help",
 814          '!' => "eval the rest of the line as perl",
 815          a => "whois author",
 816          autobundle => "wtite inventory into a bundle file",
 817          b => "info about bundle",
 818          bye => \"quit",
 819          clean => "clean up a distribution's build directory",
 820          # cvs_import
 821          d => "info about a distribution",
 822          # dump
 823          exit => \"quit",
 824          failed => "list all failed actions within current session",
 825          fforce => "redo a command from scratch",
 826          force => "redo a command",
 827          h => \"help",
 828          help => "overview over commands; 'help ...' explains specific commands",
 829          hosts => "statistics about recently used hosts",
 830          i => "info about authors/bundles/distributions/modules",
 831          install => "install a distribution",
 832          install_tested => "install all distributions tested OK",
 833          is_tested => "list all distributions tested OK",
 834          look => "open a subshell in a distribution's directory",
 835          ls => "list distributions according to a glob",
 836          m => "info about a module",
 837          make => "make/build a distribution",
 838          mkmyconfig => "write current config into a CPAN/MyConfig.pm file",
 839          notest => "run a (usually install) command but leave out the test phase",
 840          o => "'o conf ...' for config stuff; 'o debug ...' for debugging",
 841          perldoc => "try to get a manpage for a module",
 842          q => \"quit",
 843          quit => "leave the cpan shell",
 844          r => "review over upgradeable modules",
 845          readme => "display the README of a distro woth a pager",
 846          recent => "show recent uploads to the CPAN",
 847          # recompile
 848          reload => "'reload cpan' or 'reload index'",
 849          report => "test a distribution and send a test report to cpantesters",
 850          reports => "info about reported tests from cpantesters",
 851          # scripts
 852          # smoke
 853          test => "test a distribution",
 854          u => "display uninstalled modules",
 855          upgrade => "combine 'r' command with immediate installation",
 856         };
 857 {
 858     $autoload_recursion   ||= 0;
 859
 860     #-> sub CPAN::Shell::AUTOLOAD ;
 861     sub AUTOLOAD {
 862         $autoload_recursion++;
 863         my($l) = $AUTOLOAD;
 864         my $class = shift(@_);
 865         # warn "autoload[$l] class[$class]";
 866         $l =~ s/.*:://;
 867         if ($CPAN::Signal) {
 868             warn "Refusing to autoload '$l' while signal pending";
 869             $autoload_recursion--;
 870             return;
 871         }
 872         if ($autoload_recursion > 1) {
 873             my $fullcommand = join " ", map { "'$_'" } $l, @_;
 874             warn "Refusing to autoload $fullcommand in recursion\n";
 875             $autoload_recursion--;
 876             return;
 877         }
 878         if ($l =~ /^w/) {
 879             # XXX needs to be reconsidered
 880             if ($CPAN::META->has_inst('CPAN::WAIT')) {
 881                 CPAN::WAIT->$l(@_);
 882             } else {
 883                 $CPAN::Frontend->mywarn(qq{
 884 Commands starting with "w" require CPAN::WAIT to be installed.
 885 Please consider installing CPAN::WAIT to use the fulltext index.
 886 For this you just need to type
 887     install CPAN::WAIT
 888 });
 889             }
 890         } else {
 891             $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }.
 892                                     qq{Type ? for help.
 893 });
 894         }
 895         $autoload_recursion--;
 896     }
 897 }
 898
 899 package CPAN;
 900 use strict;
 901
 902 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
 903
 904 # from here on only subs.
 905 ################################################################################
 906
 907 sub _perl_fingerprint {
 908     my($self,$other_fingerprint) = @_;
 909     my $dll = eval {OS2::DLLname()};
 910     my $mtime_dll = 0;
 911     if (defined $dll) {
 912         $mtime_dll = (-f $dll ? (stat(_))[9] : '-1');
 913     }
 914     my $mtime_perl = (-f CPAN::find_perl ? (stat(_))[9] : '-1');
 915     my $this_fingerprint = {
 916                             '$^X' => CPAN::find_perl,
 917                             sitearchexp => $Config::Config{sitearchexp},
 918                             'mtime_$^X' => $mtime_perl,
 919                             'mtime_dll' => $mtime_dll,
 920                            };
 921     if ($other_fingerprint) {
 922         if (exists $other_fingerprint->{'stat($^X)'}) { # repair fp from rev. 1.88_57
 923             $other_fingerprint->{'mtime_$^X'} = $other_fingerprint->{'stat($^X)'}[9];
 924         }
 925         # mandatory keys since 1.88_57
 926         for my $key (qw($^X sitearchexp mtime_dll mtime_$^X)) {
 927             return unless $other_fingerprint->{$key} eq $this_fingerprint->{$key};
 928         }
 929         return 1;
 930     } else {
 931         return $this_fingerprint;
 932     }
 933 }
 934
 935 sub suggest_myconfig () {
 936   SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) {
 937         $CPAN::Frontend->myprint("You don't seem to have a user ".
 938                                  "configuration (MyConfig.pm) yet.\n");
 939         my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ".
 940                                               "user configuration now? (Y/n)",
 941                                               "yes");
 942         if($new =~ m{^y}i) {
 943             CPAN::Shell->mkmyconfig();
 944             return &checklock;
 945         } else {
 946             $CPAN::Frontend->mydie("OK, giving up.");
 947         }
 948     }
 949 }
 950
 951 #-> sub CPAN::all_objects ;
 952 sub all_objects {
 953     my($mgr,$class) = @_;
 954     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 955     CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
 956     CPAN::Index->reload;
 957     values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
 958 }
 959
 960 # Called by shell, not in batch mode. In batch mode I see no risk in
 961 # having many processes updating something as installations are
 962 # continually checked at runtime. In shell mode I suspect it is
 963 # unintentional to open more than one shell at a time
 964
 965 #-> sub CPAN::checklock ;
 966 sub checklock {
 967     my($self) = @_;
 968     my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
 969     if (-f $lockfile && -M _ > 0) {
 970         my $fh = FileHandle->new($lockfile) or
 971             $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
 972         my $otherpid  = <$fh>;
 973         my $otherhost = <$fh>;
 974         $fh->close;
 975         if (defined $otherpid && $otherpid) {
 976             chomp $otherpid;
 977         }
 978         if (defined $otherhost && $otherhost) {
 979             chomp $otherhost;
 980         }
 981         my $thishost  = hostname();
 982         if (defined $otherhost && defined $thishost &&
 983             $otherhost ne '' && $thishost ne '' &&
 984             $otherhost ne $thishost) {
 985             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
 986                                            "reports other host $otherhost and other ".
 987                                            "process $otherpid.\n".
 988                                            "Cannot proceed.\n"));
 989         } elsif ($RUN_DEGRADED) {
 990             $CPAN::Frontend->mywarn("Running in degraded mode (experimental)\n");
 991         } elsif (defined $otherpid && $otherpid) {
 992             return if $$ == $otherpid; # should never happen
 993             $CPAN::Frontend->mywarn(
 994                                     qq{
 995 There seems to be running another CPAN process (pid $otherpid).  Contacting...
 996 });
 997             if (kill 0, $otherpid) {
 998                 $CPAN::Frontend->mywarn(qq{Other job is running.\n});
 999                 my($ans) =
1000                     CPAN::Shell::colorable_makemaker_prompt
1001                         (qq{Shall I try to run in degraded }.
1002                         qq{mode? (Y/n)},"y");
1003                 if ($ans =~ /^y/i) {
1004                     $CPAN::Frontend->mywarn("Running in degraded mode (experimental).
1005 Please report if something unexpected happens\n");
1006                     $RUN_DEGRADED = 1;
1007                     for ($CPAN::Config) {
1008                         # XXX
1009                         # $_->{build_dir_reuse} = 0; # 2006-11-17 akoenig Why was that?
1010                         $_->{commandnumber_in_prompt} = 0; # visibility
1011                         $_->{histfile} = "";               # who should win otherwise?
1012                         $_->{cache_metadata} = 0;          # better would be a lock?
1013                         $_->{use_sqlite} = 0;              # better would be a write lock!
1014                     }
1015                 } else {
1016                     $CPAN::Frontend->mydie("
1017 You may want to kill the other job and delete the lockfile. On UNIX try:
1018     kill $otherpid
1019     rm $lockfile
1020 ");
1021                 }
1022             } elsif (-w $lockfile) {
1023                 my($ans) =
1024                     CPAN::Shell::colorable_makemaker_prompt
1025                         (qq{Other job not responding. Shall I overwrite }.
1026                         qq{the lockfile '$lockfile'? (Y/n)},"y");
1027             $CPAN::Frontend->myexit("Ok, bye\n")
1028                 unless $ans =~ /^y/i;
1029             } else {
1030                 Carp::croak(
1031                     qq{Lockfile '$lockfile' not writeable by you. }.
1032                     qq{Cannot proceed.\n}.
1033                     qq{    On UNIX try:\n}.
1034                     qq{    rm '$lockfile'\n}.
1035                     qq{  and then rerun us.\n}
1036                 );
1037             }
1038         } else {
1039             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Found invalid lockfile ".
1040                                            "'$lockfile', please remove. Cannot proceed.\n"));
1041         }
1042     }
1043     my $dotcpan = $CPAN::Config->{cpan_home};
1044     eval { File::Path::mkpath($dotcpan);};
1045     if ($@) {
1046         # A special case at least for Jarkko.
1047         my $firsterror = $@;
1048         my $seconderror;
1049         my $symlinkcpan;
1050         if (-l $dotcpan) {
1051             $symlinkcpan = readlink $dotcpan;
1052             die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
1053             eval { File::Path::mkpath($symlinkcpan); };
1054             if ($@) {
1055                 $seconderror = $@;
1056             } else {
1057                 $CPAN::Frontend->mywarn(qq{
1058 Working directory $symlinkcpan created.
1059 });
1060             }
1061         }
1062         unless (-d $dotcpan) {
1063             my $mess = qq{
1064 Your configuration suggests "$dotcpan" as your
1065 CPAN.pm working directory. I could not create this directory due
1066 to this error: $firsterror\n};
1067             $mess .= qq{
1068 As "$dotcpan" is a symlink to "$symlinkcpan",
1069 I tried to create that, but I failed with this error: $seconderror
1070 } if $seconderror;
1071             $mess .= qq{
1072 Please make sure the directory exists and is writable.
1073 };
1074             $CPAN::Frontend->mywarn($mess);
1075             return suggest_myconfig;
1076         }
1077     } # $@ after eval mkpath $dotcpan
1078     if (0) { # to test what happens when a race condition occurs
1079         for (reverse 1..10) {
1080             print $_, "\n";
1081             sleep 1;
1082         }
1083     }
1084     # locking
1085     if (!$RUN_DEGRADED && !$self->{LOCKFH}) {
1086         my $fh;
1087         unless ($fh = FileHandle->new("+>>$lockfile")) {
1088             if ($! =~ /Permission/) {
1089                 $CPAN::Frontend->mywarn(qq{
1090
1091 Your configuration suggests that CPAN.pm should use a working
1092 directory of
1093     $CPAN::Config->{cpan_home}
1094 Unfortunately we could not create the lock file
1095     $lockfile
1096 due to permission problems.
1097
1098 Please make sure that the configuration variable
1099     \$CPAN::Config->{cpan_home}
1100 points to a directory where you can write a .lock file. You can set
1101 this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
1102 \@INC path;
1103 });
1104                 return suggest_myconfig;
1105             }
1106         }
1107         my $sleep = 1;
1108         while (!CPAN::_flock($fh, LOCK_EX|LOCK_NB)) {
1109             if ($sleep>10) {
1110                 $CPAN::Frontend->mydie("Giving up\n");
1111             }
1112             $CPAN::Frontend->mysleep($sleep++);
1113             $CPAN::Frontend->mywarn("Could not lock lockfile with flock: $!; retrying\n");
1114         }
1115
1116         seek $fh, 0, 0;
1117         truncate $fh, 0;
1118         $fh->autoflush(1);
1119         $fh->print($$, "\n");
1120         $fh->print(hostname(), "\n");
1121         $self->{LOCK} = $lockfile;
1122         $self->{LOCKFH} = $fh;
1123     }
1124     $SIG{TERM} = sub {
1125         my $sig = shift;
1126         &cleanup;
1127         $CPAN::Frontend->mydie("Got SIG$sig, leaving");
1128     };
1129     $SIG{INT} = sub {
1130       # no blocks!!!
1131         my $sig = shift;
1132         &cleanup if $Signal;
1133         die "Got yet another signal" if $Signal > 1;
1134         $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal;
1135         $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n");
1136         $Signal++;
1137     };
1138
1139 #       From: Larry Wall <larry@wall.org>
1140 #       Subject: Re: deprecating SIGDIE
1141 #       To: perl5-porters@perl.org
1142 #       Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
1143 #
1144 #       The original intent of __DIE__ was only to allow you to substitute one
1145 #       kind of death for another on an application-wide basis without respect
1146 #       to whether you were in an eval or not.  As a global backstop, it should
1147 #       not be used any more lightly (or any more heavily :-) than class
1148 #       UNIVERSAL.  Any attempt to build a general exception model on it should
1149 #       be politely squashed.  Any bug that causes every eval {} to have to be
1150 #       modified should be not so politely squashed.
1151 #
1152 #       Those are my current opinions.  It is also my optinion that polite
1153 #       arguments degenerate to personal arguments far too frequently, and that
1154 #       when they do, it's because both people wanted it to, or at least didn't
1155 #       sufficiently want it not to.
1156 #
1157 #       Larry
1158
1159     # global backstop to cleanup if we should really die
1160     $SIG{__DIE__} = \&cleanup;
1161     $self->debug("Signal handler set.") if $CPAN::DEBUG;
1162 }
1163
1164 #-> sub CPAN::DESTROY ;
1165 sub DESTROY {
1166     &cleanup; # need an eval?
1167 }
1168
1169 #-> sub CPAN::anycwd ;
1170 sub anycwd () {
1171     my $getcwd;
1172     $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
1173     CPAN->$getcwd();
1174 }
1175
1176 #-> sub CPAN::cwd ;
1177 sub cwd {Cwd::cwd();}
1178
1179 #-> sub CPAN::getcwd ;
1180 sub getcwd {Cwd::getcwd();}
1181
1182 #-> sub CPAN::fastcwd ;
1183 sub fastcwd {Cwd::fastcwd();}
1184
1185 #-> sub CPAN::backtickcwd ;
1186 sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
1187
1188 #-> sub CPAN::find_perl ;
1189 sub find_perl () {
1190     my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
1191     my $pwd  = $CPAN::iCwd = CPAN::anycwd();
1192     my $candidate = File::Spec->catfile($pwd,$^X);
1193     $perl ||= $candidate if MM->maybe_command($candidate);
1194
1195     unless ($perl) {
1196         my ($component,$perl_name);
1197       DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
1198           PATH_COMPONENT: foreach $component (File::Spec->path(),
1199                                                 $Config::Config{'binexp'}) {
1200                 next unless defined($component) && $component;
1201                 my($abs) = File::Spec->catfile($component,$perl_name);
1202                 if (MM->maybe_command($abs)) {
1203                     $perl = $abs;
1204                     last DIST_PERLNAME;
1205                 }
1206             }
1207         }
1208     }
1209
1210     return $perl;
1211 }
1212
1213
1214 #-> sub CPAN::exists ;
1215 sub exists {
1216     my($mgr,$class,$id) = @_;
1217     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
1218     CPAN::Index->reload;
1219     ### Carp::croak "exists called without class argument" unless $class;
1220     $id ||= "";
1221     $id =~ s/:+/::/g if $class eq "CPAN::Module";
1222     my $exists;
1223     if (CPAN::_sqlite_running) {
1224         $exists = (exists $META->{readonly}{$class}{$id} or
1225                    $CPAN::SQLite->set($class, $id));
1226     } else {
1227         $exists =  exists $META->{readonly}{$class}{$id};
1228     }
1229     $exists ||= exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
1230 }
1231
1232 #-> sub CPAN::delete ;
1233 sub delete {
1234   my($mgr,$class,$id) = @_;
1235   delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
1236   delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
1237 }
1238
1239 #-> sub CPAN::has_usable
1240 # has_inst is sometimes too optimistic, we should replace it with this
1241 # has_usable whenever a case is given
1242 sub has_usable {
1243     my($self,$mod,$message) = @_;
1244     return 1 if $HAS_USABLE->{$mod};
1245     my $has_inst = $self->has_inst($mod,$message);
1246     return unless $has_inst;
1247     my $usable;
1248     $usable = {
1249                LWP => [ # we frequently had "Can't locate object
1250                         # method "new" via package "LWP::UserAgent" at
1251                         # (eval 69) line 2006
1252                        sub {require LWP},
1253                        sub {require LWP::UserAgent},
1254                        sub {require HTTP::Request},
1255                        sub {require URI::URL},
1256                       ],
1257                'Net::FTP' => [
1258                             sub {require Net::FTP},
1259                             sub {require Net::Config},
1260                            ],
1261                'File::HomeDir' => [
1262                                    sub {require File::HomeDir;
1263                                         unless (CPAN::Version->vge(File::HomeDir::->VERSION, 0.52)) {
1264                                             for ("Will not use File::HomeDir, need 0.52\n") {
1265                                                 $CPAN::Frontend->mywarn($_);
1266                                                 die $_;
1267                                             }
1268                                         }
1269                                     },
1270                                   ],
1271                'Archive::Tar' => [
1272                                   sub {require Archive::Tar;
1273                                        unless (CPAN::Version->vge(Archive::Tar::->VERSION, 1.00)) {
1274                                             for ("Will not use Archive::Tar, need 1.00\n") {
1275                                                 $CPAN::Frontend->mywarn($_);
1276                                                 die $_;
1277                                             }
1278                                        }
1279                                   },
1280                                  ],
1281                'File::Temp' => [
1282                                 # XXX we should probably delete from
1283                                 # %INC too so we can load after we
1284                                 # installed a new enough version --
1285                                 # I'm not sure.
1286                                 sub {require File::Temp;
1287                                      unless (CPAN::Version->vge(File::Temp::->VERSION,0.16)) {
1288                                          for ("Will not use File::Temp, need 0.16\n") {
1289                                                 $CPAN::Frontend->mywarn($_);
1290                                                 die $_;
1291                                          }
1292                                      }
1293                                 },
1294                                ]
1295               };
1296     if ($usable->{$mod}) {
1297         for my $c (0..$#{$usable->{$mod}}) {
1298             my $code = $usable->{$mod}[$c];
1299             my $ret = eval { &$code() };
1300             $ret = "" unless defined $ret;
1301             if ($@) {
1302                 # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
1303                 return;
1304             }
1305         }
1306     }
1307     return $HAS_USABLE->{$mod} = 1;
1308 }
1309
1310 #-> sub CPAN::has_inst
1311 sub has_inst {
1312     my($self,$mod,$message) = @_;
1313     Carp::croak("CPAN->has_inst() called without an argument")
1314         unless defined $mod;
1315     my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
1316         keys %{$CPAN::Config->{dontload_hash}||{}},
1317             @{$CPAN::Config->{dontload_list}||[]};
1318     if (defined $message && $message eq "no"  # afair only used by Nox
1319         ||
1320         $dont{$mod}
1321        ) {
1322       $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
1323       return 0;
1324     }
1325     my $file = $mod;
1326     my $obj;
1327     $file =~ s|::|/|g;
1328     $file .= ".pm";
1329     if ($INC{$file}) {
1330         # checking %INC is wrong, because $INC{LWP} may be true
1331         # although $INC{"URI/URL.pm"} may have failed. But as
1332         # I really want to say "bla loaded OK", I have to somehow
1333         # cache results.
1334         ### warn "$file in %INC"; #debug
1335         return 1;
1336     } elsif (eval { require $file }) {
1337         # eval is good: if we haven't yet read the database it's
1338         # perfect and if we have installed the module in the meantime,
1339         # it tries again. The second require is only a NOOP returning
1340         # 1 if we had success, otherwise it's retrying
1341
1342         my $mtime = (stat $INC{$file})[9];
1343         # privileged files loaded by has_inst; Note: we use $mtime
1344         # as a proxy for a checksum.
1345         $CPAN::Shell::reload->{$file} = $mtime;
1346         my $v = eval "\$$mod\::VERSION";
1347         $v = $v ? " (v$v)" : "";
1348         CPAN::Shell->optprint("load_module","CPAN: $mod loaded ok$v\n");
1349         if ($mod eq "CPAN::WAIT") {
1350             push @CPAN::Shell::ISA, 'CPAN::WAIT';
1351         }
1352         return 1;
1353     } elsif ($mod eq "Net::FTP") {
1354         $CPAN::Frontend->mywarn(qq{
1355   Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
1356   if you just type
1357       install Bundle::libnet
1358
1359 }) unless $Have_warned->{"Net::FTP"}++;
1360         $CPAN::Frontend->mysleep(3);
1361     } elsif ($mod eq "Digest::SHA") {
1362         if ($Have_warned->{"Digest::SHA"}++) {
1363             $CPAN::Frontend->mywarn(qq{CPAN: checksum security checks disabled }.
1364                                      qq{because Digest::SHA not installed.\n});
1365         } else {
1366             $CPAN::Frontend->mywarn(qq{
1367   CPAN: checksum security checks disabled because Digest::SHA not installed.
1368   Please consider installing the Digest::SHA module.
1369
1370 });
1371             $CPAN::Frontend->mysleep(2);
1372         }
1373     } elsif ($mod eq "Module::Signature") {
1374         # NOT prefs_lookup, we are not a distro
1375         my $check_sigs = $CPAN::Config->{check_sigs};
1376         if (not $check_sigs) {
1377             # they do not want us:-(
1378         } elsif (not $Have_warned->{"Module::Signature"}++) {
1379             # No point in complaining unless the user can
1380             # reasonably install and use it.
1381             if (eval { require Crypt::OpenPGP; 1 } ||
1382                 (
1383                  defined $CPAN::Config->{'gpg'}
1384                  &&
1385                  $CPAN::Config->{'gpg'} =~ /\S/
1386                 )
1387                ) {
1388                 $CPAN::Frontend->mywarn(qq{
1389   CPAN: Module::Signature security checks disabled because Module::Signature
1390   not installed.  Please consider installing the Module::Signature module.
1391   You may also need to be able to connect over the Internet to the public
1392   keyservers like pgp.mit.edu (port 11371).
1393
1394 });
1395                 $CPAN::Frontend->mysleep(2);
1396             }
1397         }
1398     } else {
1399         delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
1400     }
1401     return 0;
1402 }
1403
1404 #-> sub CPAN::instance ;
1405 sub instance {
1406     my($mgr,$class,$id) = @_;
1407     CPAN::Index->reload;
1408     $id ||= "";
1409     # unsafe meta access, ok?
1410     return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
1411     $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
1412 }
1413
1414 #-> sub CPAN::new ;
1415 sub new {
1416     bless {}, shift;
1417 }
1418
1419 #-> sub CPAN::cleanup ;
1420 sub cleanup {
1421   # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
1422   local $SIG{__DIE__} = '';
1423   my($message) = @_;
1424   my $i = 0;
1425   my $ineval = 0;
1426   my($subroutine);
1427   while ((undef,undef,undef,$subroutine) = caller(++$i)) {
1428       $ineval = 1, last if
1429         $subroutine eq '(eval)';
1430   }
1431   return if $ineval && !$CPAN::End;
1432   return unless defined $META->{LOCK};
1433   return unless -f $META->{LOCK};
1434   $META->savehist;
1435   close $META->{LOCKFH};
1436   unlink $META->{LOCK};
1437   # require Carp;
1438   # Carp::cluck("DEBUGGING");
1439   if ( $CPAN::CONFIG_DIRTY ) {
1440       $CPAN::Frontend->mywarn("Warning: Configuration not saved.\n");
1441   }
1442   $CPAN::Frontend->myprint("Lockfile removed.\n");
1443 }
1444
1445 #-> sub CPAN::readhist
1446 sub readhist {
1447     my($self,$term,$histfile) = @_;
1448     my($fh) = FileHandle->new;
1449     open $fh, "<$histfile" or last;
1450     local $/ = "\n";
1451     while (<$fh>) {
1452         chomp;
1453         $term->AddHistory($_);
1454     }
1455     close $fh;
1456 }
1457
1458 #-> sub CPAN::savehist
1459 sub savehist {
1460     my($self) = @_;
1461     my($histfile,$histsize);
1462     unless ($histfile = $CPAN::Config->{'histfile'}) {
1463         $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
1464         return;
1465     }
1466     $histsize = $CPAN::Config->{'histsize'} || 100;
1467     if ($CPAN::term) {
1468         unless ($CPAN::term->can("GetHistory")) {
1469             $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
1470             return;
1471         }
1472     } else {
1473         return;
1474     }
1475     my @h = $CPAN::term->GetHistory;
1476     splice @h, 0, @h-$histsize if @h>$histsize;
1477     my($fh) = FileHandle->new;
1478     open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
1479     local $\ = local $, = "\n";
1480     print $fh @h;
1481     close $fh;
1482 }
1483
1484 #-> sub CPAN::is_tested
1485 sub is_tested {
1486     my($self,$what,$when) = @_;
1487     unless ($what) {
1488         Carp::cluck("DEBUG: empty what");
1489         return;
1490     }
1491     $self->{is_tested}{$what} = $when;
1492 }
1493
1494 #-> sub CPAN::is_installed
1495 # unsets the is_tested flag: as soon as the thing is installed, it is
1496 # not needed in set_perl5lib anymore
1497 sub is_installed {
1498     my($self,$what) = @_;
1499     delete $self->{is_tested}{$what};
1500 }
1501
1502 sub _list_sorted_descending_is_tested {
1503     my($self) = @_;
1504     sort
1505         { ($self->{is_tested}{$b}||0) <=> ($self->{is_tested}{$a}||0) }
1506             keys %{$self->{is_tested}}
1507 }
1508
1509 #-> sub CPAN::set_perl5lib
1510 sub set_perl5lib {
1511     my($self,$for) = @_;
1512     unless ($for) {
1513         (undef,undef,undef,$for) = caller(1);
1514         $for =~ s/.*://;
1515     }
1516     $self->{is_tested} ||= {};
1517     return unless %{$self->{is_tested}};
1518     my $env = $ENV{PERL5LIB};
1519     $env = $ENV{PERLLIB} unless defined $env;
1520     my @env;
1521     push @env, $env if defined $env and length $env;
1522     #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
1523     #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
1524
1525     my @dirs = map {("$_/blib/arch", "$_/blib/lib")} $self->_list_sorted_descending_is_tested;
1526     if (@dirs < 12) {
1527         $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB for '$for'\n");
1528     } elsif (@dirs < 24) {
1529         my @d = map {my $cp = $_;
1530                      $cp =~ s/^\Q$CPAN::Config->{build_dir}\E/%BUILDDIR%/;
1531                      $cp
1532                  } @dirs;
1533         $CPAN::Frontend->myprint("Prepending @d to PERL5LIB; ".
1534                                  "%BUILDDIR%=$CPAN::Config->{build_dir} ".
1535                                  "for '$for'\n"
1536                                 );
1537     } else {
1538         my $cnt = keys %{$self->{is_tested}};
1539         $CPAN::Frontend->myprint("Prepending blib/arch and blib/lib of ".
1540                                  "$cnt build dirs to PERL5LIB; ".
1541                                  "for '$for'\n"
1542                                 );
1543     }
1544
1545     $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1546 }
1547
1548 package CPAN::CacheMgr;
1549 use strict;
1550
1551 #-> sub CPAN::CacheMgr::as_string ;
1552 sub as_string {
1553     eval { require Data::Dumper };
1554     if ($@) {
1555         return shift->SUPER::as_string;
1556     } else {
1557         return Data::Dumper::Dumper(shift);
1558     }
1559 }
1560
1561 #-> sub CPAN::CacheMgr::cachesize ;
1562 sub cachesize {
1563     shift->{DU};
1564 }
1565
1566 #-> sub CPAN::CacheMgr::tidyup ;
1567 sub tidyup {
1568   my($self) = @_;
1569   return unless $CPAN::META->{LOCK};
1570   return unless -d $self->{ID};
1571   my @toremove = grep { $self->{SIZE}{$_}==0 } @{$self->{FIFO}};
1572   for my $current (0..$#toremove) {
1573     my $toremove = $toremove[$current];
1574     $CPAN::Frontend->myprint(sprintf(
1575                                      "DEL(%d/%d): %s \n",
1576                                      $current+1,
1577                                      scalar @toremove,
1578                                      $toremove,
1579                                     )
1580                             );
1581     return if $CPAN::Signal;
1582     $self->_clean_cache($toremove);
1583     return if $CPAN::Signal;
1584   }
1585 }
1586
1587 #-> sub CPAN::CacheMgr::dir ;
1588 sub dir {
1589     shift->{ID};
1590 }
1591
1592 #-> sub CPAN::CacheMgr::entries ;
1593 sub entries {
1594     my($self,$dir) = @_;
1595     return unless defined $dir;
1596     $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
1597     $dir ||= $self->{ID};
1598     my($cwd) = CPAN::anycwd();
1599     chdir $dir or Carp::croak("Can't chdir to $dir: $!");
1600     my $dh = DirHandle->new(File::Spec->curdir)
1601         or Carp::croak("Couldn't opendir $dir: $!");
1602     my(@entries);
1603     for ($dh->read) {
1604         next if $_ eq "." || $_ eq "..";
1605         if (-f $_) {
1606             push @entries, File::Spec->catfile($dir,$_);
1607         } elsif (-d _) {
1608             push @entries, File::Spec->catdir($dir,$_);
1609         } else {
1610             $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
1611         }
1612     }
1613     chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
1614     sort { -M $a <=> -M $b} @entries;
1615 }
1616
1617 #-> sub CPAN::CacheMgr::disk_usage ;
1618 sub disk_usage {
1619     my($self,$dir,$fast) = @_;
1620     return if exists $self->{SIZE}{$dir};
1621     return if $CPAN::Signal;
1622     my($Du) = 0;
1623     if (-e $dir) {
1624         if (-d $dir) {
1625             unless (-x $dir) {
1626                 unless (chmod 0755, $dir) {
1627                     $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
1628                                             "permission to change the permission; cannot ".
1629                                             "estimate disk usage of '$dir'\n");
1630                     $CPAN::Frontend->mysleep(5);
1631                     return;
1632                 }
1633             }
1634         } elsif (-f $dir) {
1635             # nothing to say, no matter what the permissions
1636         }
1637     } else {
1638         $CPAN::Frontend->mywarn("File or directory '$dir' has gone, ignoring\n");
1639         return;
1640     }
1641     if ($fast) {
1642         $Du = 0; # placeholder
1643     } else {
1644         find(
1645              sub {
1646            $File::Find::prune++ if $CPAN::Signal;
1647            return if -l $_;
1648            if ($^O eq 'MacOS') {
1649              require Mac::Files;
1650              my $cat  = Mac::Files::FSpGetCatInfo($_);
1651              $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
1652            } else {
1653              if (-d _) {
1654                unless (-x _) {
1655                  unless (chmod 0755, $_) {
1656                    $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
1657                                            "the permission to change the permission; ".
1658                                            "can only partially estimate disk usage ".
1659                                            "of '$_'\n");
1660                    $CPAN::Frontend->mysleep(5);
1661                    return;
1662                  }
1663                }
1664              } else {
1665                $Du += (-s _);
1666              }
1667            }
1668          },
1669          $dir
1670             );
1671     }
1672     return if $CPAN::Signal;
1673     $self->{SIZE}{$dir} = $Du/1024/1024;
1674     unshift @{$self->{FIFO}}, $dir;
1675     $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
1676     $self->{DU} += $Du/1024/1024;
1677     $self->{DU};
1678 }
1679
1680 #-> sub CPAN::CacheMgr::_clean_cache ;
1681 sub _clean_cache {
1682     my($self,$dir) = @_;
1683     return unless -e $dir;
1684     unless (File::Spec->canonpath(File::Basename::dirname($dir))
1685             eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
1686         $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
1687                                 "will not remove\n");
1688         $CPAN::Frontend->mysleep(5);
1689         return;
1690     }
1691     $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
1692         if $CPAN::DEBUG;
1693     File::Path::rmtree($dir);
1694     my $id_deleted = 0;
1695     if ($dir !~ /\.yml$/ && -f "$dir.yml") {
1696         my $yaml_module = CPAN::_yaml_module;
1697         if ($CPAN::META->has_inst($yaml_module)) {
1698             my($peek_yaml) = eval { CPAN->_yaml_loadfile("$dir.yml"); };
1699             if ($@) {
1700                 $CPAN::Frontend->mywarn("(parse error on '$dir.yml' removing anyway)");
1701                 unlink "$dir.yml" or
1702                     $CPAN::Frontend->mywarn("(Could not unlink '$dir.yml': $!)");
1703                 return;
1704             } elsif (my $id = $peek_yaml->[0]{distribution}{ID}) {
1705                 $CPAN::META->delete("CPAN::Distribution", $id);
1706
1707                 # XXX we should restore the state NOW, otherise this
1708                 # distro does not exist until we read an index. BUG ALERT(?)
1709
1710                 # $CPAN::Frontend->mywarn (" +++\n");
1711                 $id_deleted++;
1712             }
1713         }
1714         unlink "$dir.yml"; # may fail
1715         unless ($id_deleted) {
1716             CPAN->debug("no distro found associated with '$dir'");
1717         }
1718     }
1719     $self->{DU} -= $self->{SIZE}{$dir};
1720     delete $self->{SIZE}{$dir};
1721 }
1722
1723 #-> sub CPAN::CacheMgr::new ;
1724 sub new {
1725     my $class = shift;
1726     my $time = time;
1727     my($debug,$t2);
1728     $debug = "";
1729     my $self = {
1730         ID => $CPAN::Config->{build_dir},
1731         MAX => $CPAN::Config->{'build_cache'},
1732         SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
1733         DU => 0
1734     };
1735     File::Path::mkpath($self->{ID});
1736     my $dh = DirHandle->new($self->{ID});
1737     bless $self, $class;
1738     $self->scan_cache;
1739     $t2 = time;
1740     $debug .= "timing of CacheMgr->new: ".($t2 - $time);
1741     $time = $t2;
1742     CPAN->debug($debug) if $CPAN::DEBUG;
1743     $self;
1744 }
1745
1746 #-> sub CPAN::CacheMgr::scan_cache ;
1747 sub scan_cache {
1748     my $self = shift;
1749     return if $self->{SCAN} eq 'never';
1750     $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
1751         unless $self->{SCAN} eq 'atstart';
1752     return unless $CPAN::META->{LOCK};
1753     $CPAN::Frontend->myprint(
1754                              sprintf("Scanning cache %s for sizes\n",
1755                              $self->{ID}));
1756     my $e;
1757     my @entries = $self->entries($self->{ID});
1758     my $i = 0;
1759     my $painted = 0;
1760     for $e (@entries) {
1761         my $symbol = ".";
1762         if ($self->{DU} > $self->{MAX}) {
1763             $symbol = "-";
1764             $self->disk_usage($e,1);
1765         } else {
1766             $self->disk_usage($e);
1767         }
1768         $i++;
1769         while (($painted/76) < ($i/@entries)) {
1770             $CPAN::Frontend->myprint($symbol);
1771             $painted++;
1772         }
1773         return if $CPAN::Signal;
1774     }
1775     $CPAN::Frontend->myprint("DONE\n");
1776     $self->tidyup;
1777 }
1778
1779 package CPAN::Shell;
1780 use strict;
1781
1782 #-> sub CPAN::Shell::h ;
1783 sub h {
1784     my($class,$about) = @_;
1785     if (defined $about) {
1786         my $help;
1787         if (exists $Help->{$about}) {
1788             if (ref $Help->{$about}) { # aliases
1789                 $about = ${$Help->{$about}};
1790             }
1791             $help = $Help->{$about};
1792         } else {
1793             $help = "No help available";
1794         }
1795         $CPAN::Frontend->myprint("$about\: $help\n");
1796     } else {
1797         my $filler = " " x (80 - 28 - length($CPAN::VERSION));
1798         $CPAN::Frontend->myprint(qq{
1799 Display Information $filler (ver $CPAN::VERSION)
1800  command  argument          description
1801  a,b,d,m  WORD or /REGEXP/  about authors, bundles, distributions, modules
1802  i        WORD or /REGEXP/  about any of the above
1803  ls       AUTHOR or GLOB    about files in the author's directory
1804     (with WORD being a module, bundle or author name or a distribution
1805     name of the form AUTHOR/DISTRIBUTION)
1806
1807 Download, Test, Make, Install...
1808  get      download                     clean    make clean
1809  make     make (implies get)           look     open subshell in dist directory
1810  test     make test (implies make)     readme   display these README files
1811  install  make install (implies test)  perldoc  display POD documentation
1812
1813 Upgrade
1814  r        WORDs or /REGEXP/ or NONE    report updates for some/matching/all modules
1815  upgrade  WORDs or /REGEXP/ or NONE    upgrade some/matching/all modules
1816
1817 Pragmas
1818  force  CMD    try hard to do command  fforce CMD    try harder
1819  notest CMD    skip testing
1820
1821 Other
1822  h,?           display this menu       ! perl-code   eval a perl command
1823  o conf [opt]  set and query options   q             quit the cpan shell
1824  reload cpan   load CPAN.pm again      reload index  load newer indices
1825  autobundle    Snapshot                recent        latest CPAN uploads});
1826 }
1827 }
1828
1829 *help = \&h;
1830
1831 #-> sub CPAN::Shell::a ;
1832 sub a {
1833   my($self,@arg) = @_;
1834   # authors are always UPPERCASE
1835   for (@arg) {
1836     $_ = uc $_ unless /=/;
1837   }
1838   $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1839 }
1840
1841 #-> sub CPAN::Shell::globls ;
1842 sub globls {
1843     my($self,$s,$pragmas) = @_;
1844     # ls is really very different, but we had it once as an ordinary
1845     # command in the Shell (upto rev. 321) and we could not handle
1846     # force well then
1847     my(@accept,@preexpand);
1848     if ($s =~ /[\*\?\/]/) {
1849         if ($CPAN::META->has_inst("Text::Glob")) {
1850             if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
1851                 my $rau = Text::Glob::glob_to_regex(uc $au);
1852                 CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
1853                       if $CPAN::DEBUG;
1854                 push @preexpand, map { $_->id . "/" . $pathglob }
1855                     CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
1856             } else {
1857                 my $rau = Text::Glob::glob_to_regex(uc $s);
1858                 push @preexpand, map { $_->id }
1859                     CPAN::Shell->expand_by_method('CPAN::Author',
1860                                                   ['id'],
1861                                                   "/$rau/");
1862             }
1863         } else {
1864             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
1865         }
1866     } else {
1867         push @preexpand, uc $s;
1868     }
1869     for (@preexpand) {
1870         unless (/^[A-Z0-9\-]+(\/|$)/i) {
1871             $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
1872             next;
1873         }
1874         push @accept, $_;
1875     }
1876     my $silent = @accept>1;
1877     my $last_alpha = "";
1878     my @results;
1879     for my $a (@accept) {
1880         my($author,$pathglob);
1881         if ($a =~ m|(.*?)/(.*)|) {
1882             my $a2 = $1;
1883             $pathglob = $2;
1884             $author = CPAN::Shell->expand_by_method('CPAN::Author',
1885                                                     ['id'],
1886                                                     $a2)
1887                 or $CPAN::Frontend->mydie("No author found for $a2\n");
1888         } else {
1889             $author = CPAN::Shell->expand_by_method('CPAN::Author',
1890                                                     ['id'],
1891                                                     $a)
1892                 or $CPAN::Frontend->mydie("No author found for $a\n");
1893         }
1894         if ($silent) {
1895             my $alpha = substr $author->id, 0, 1;
1896             my $ad;
1897             if ($alpha eq $last_alpha) {
1898                 $ad = "";
1899             } else {
1900                 $ad = "[$alpha]";
1901                 $last_alpha = $alpha;
1902             }
1903             $CPAN::Frontend->myprint($ad);
1904         }
1905         for my $pragma (@$pragmas) {
1906             if ($author->can($pragma)) {
1907                 $author->$pragma();
1908             }
1909         }
1910         push @results, $author->ls($pathglob,$silent); # silent if
1911                                                        # more than one
1912                                                        # author
1913         for my $pragma (@$pragmas) {
1914             my $unpragma = "un$pragma";
1915             if ($author->can($unpragma)) {
1916                 $author->$unpragma();
1917             }
1918         }
1919     }
1920     @results;
1921 }
1922
1923 #-> sub CPAN::Shell::local_bundles ;
1924 sub local_bundles {
1925     my($self,@which) = @_;
1926     my($incdir,$bdir,$dh);
1927     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1928         my @bbase = "Bundle";
1929         while (my $bbase = shift @bbase) {
1930             $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
1931             CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1932             if ($dh = DirHandle->new($bdir)) { # may fail
1933                 my($entry);
1934                 for $entry ($dh->read) {
1935                     next if $entry =~ /^\./;
1936                     next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/;
1937                     if (-d File::Spec->catdir($bdir,$entry)) {
1938                         push @bbase, "$bbase\::$entry";
1939                     } else {
1940                         next unless $entry =~ s/\.pm(?!\n)\Z//;
1941                         $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1942                     }
1943                 }
1944             }
1945         }
1946     }
1947 }
1948
1949 #-> sub CPAN::Shell::b ;
1950 sub b {
1951     my($self,@which) = @_;
1952     CPAN->debug("which[@which]") if $CPAN::DEBUG;
1953     $self->local_bundles;
1954     $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1955 }
1956
1957 #-> sub CPAN::Shell::d ;
1958 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1959
1960 #-> sub CPAN::Shell::m ;
1961 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1962     my $self = shift;
1963     $CPAN::Frontend->myprint($self->format_result('Module',@_));
1964 }
1965
1966 #-> sub CPAN::Shell::i ;
1967 sub i {
1968     my($self) = shift;
1969     my(@args) = @_;
1970     @args = '/./' unless @args;
1971     my(@result);
1972     for my $type (qw/Bundle Distribution Module/) {
1973         push @result, $self->expand($type,@args);
1974     }
1975     # Authors are always uppercase.
1976     push @result, $self->expand("Author", map { uc $_ } @args);
1977
1978     my $result = @result == 1 ?
1979         $result[0]->as_string :
1980             @result == 0 ?
1981                 "No objects found of any type for argument @args\n" :
1982                     join("",
1983                          (map {$_->as_glimpse} @result),
1984                          scalar @result, " items found\n",
1985                         );
1986     $CPAN::Frontend->myprint($result);
1987 }
1988
1989 #-> sub CPAN::Shell::o ;
1990
1991 # CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o
1992 # conf' calls through to CPAN::HandleConfig::edit. 'o conf' should
1993 # probably have been called 'set' and 'o debug' maybe 'set debug' or
1994 # 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm
1995 sub o {
1996     my($self,$o_type,@o_what) = @_;
1997     $o_type ||= "";
1998     CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1999     if ($o_type eq 'conf') {
2000         my($cfilter) = $o_what[0] =~ m|^/(.*)/$| if @o_what;
2001         if (!@o_what or $cfilter) { # print all things, "o conf"
2002             $cfilter ||= "";
2003             my $qrfilter = eval 'qr/$cfilter/';
2004             my($k,$v);
2005             $CPAN::Frontend->myprint("\$CPAN::Config options from ");
2006             my @from;
2007             if (exists $INC{'CPAN/Config.pm'}) {
2008                 push @from, $INC{'CPAN/Config.pm'};
2009             }
2010             if (exists $INC{'CPAN/MyConfig.pm'}) {
2011                 push @from, $INC{'CPAN/MyConfig.pm'};
2012             }
2013             $CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from);
2014             $CPAN::Frontend->myprint(":\n");
2015             for $k (sort keys %CPAN::HandleConfig::can) {
2016                 next unless $k =~ /$qrfilter/;
2017                 $v = $CPAN::HandleConfig::can{$k};
2018                 $CPAN::Frontend->myprint(sprintf "    %-18s [%s]\n", $k, $v);
2019             }
2020             $CPAN::Frontend->myprint("\n");
2021             for $k (sort keys %CPAN::HandleConfig::keys) {
2022                 next unless $k =~ /$qrfilter/;
2023                 CPAN::HandleConfig->prettyprint($k);
2024             }
2025             $CPAN::Frontend->myprint("\n");
2026         } else {
2027             if (CPAN::HandleConfig->edit(@o_what)) {
2028             } else {
2029                 $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
2030                                          qq{items\n\n});
2031             }
2032         }
2033     } elsif ($o_type eq 'debug') {
2034         my(%valid);
2035         @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
2036         if (@o_what) {
2037             while (@o_what) {
2038                 my($what) = shift @o_what;
2039                 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
2040                     $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
2041                     next;
2042                 }
2043                 if ( exists $CPAN::DEBUG{$what} ) {
2044                     $CPAN::DEBUG |= $CPAN::DEBUG{$what};
2045                 } elsif ($what =~ /^\d/) {
2046                     $CPAN::DEBUG = $what;
2047                 } elsif (lc $what eq 'all') {
2048                     my($max) = 0;
2049                     for (values %CPAN::DEBUG) {
2050                         $max += $_;
2051                     }
2052                     $CPAN::DEBUG = $max;
2053                 } else {
2054                     my($known) = 0;
2055                     for (keys %CPAN::DEBUG) {
2056                         next unless lc($_) eq lc($what);
2057                         $CPAN::DEBUG |= $CPAN::DEBUG{$_};
2058                         $known = 1;
2059                     }
2060                     $CPAN::Frontend->myprint("unknown argument [$what]\n")
2061                         unless $known;
2062                 }
2063             }
2064         } else {
2065             my $raw = "Valid options for debug are ".
2066                 join(", ",sort(keys %CPAN::DEBUG), 'all').
2067                      qq{ or a number. Completion works on the options. }.
2068                      qq{Case is ignored.};
2069             require Text::Wrap;
2070             $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
2071             $CPAN::Frontend->myprint("\n\n");
2072         }
2073         if ($CPAN::DEBUG) {
2074             $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n");
2075             my($k,$v);
2076             for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
2077                 $v = $CPAN::DEBUG{$k};
2078                 $CPAN::Frontend->myprint(sprintf "    %-14s(%s)\n", $k, $v)
2079                     if $v & $CPAN::DEBUG;
2080             }
2081         } else {
2082             $CPAN::Frontend->myprint("Debugging turned off completely.\n");
2083         }
2084     } else {
2085         $CPAN::Frontend->myprint(qq{
2086 Known options:
2087   conf    set or get configuration variables
2088   debug   set or get debugging options
2089 });
2090     }
2091 }
2092
2093 # CPAN::Shell::paintdots_onreload
2094 sub paintdots_onreload {
2095     my($ref) = shift;
2096     sub {
2097         if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
2098             my($subr) = $1;
2099             ++$$ref;
2100             local($|) = 1;
2101             # $CPAN::Frontend->myprint(".($subr)");
2102             $CPAN::Frontend->myprint(".");
2103             if ($subr =~ /\bshell\b/i) {
2104                 # warn "debug[$_[0]]";
2105
2106                 # It would be nice if we could detect that a
2107                 # subroutine has actually changed, but for now we
2108                 # practically always set the GOTOSHELL global
2109
2110                 $CPAN::GOTOSHELL=1;
2111             }
2112             return;
2113         }
2114         warn @_;
2115     };
2116 }
2117
2118 #-> sub CPAN::Shell::hosts ;
2119 sub hosts {
2120     my($self) = @_;
2121     my $fullstats = CPAN::FTP->_ftp_statistics();
2122     my $history = $fullstats->{history} || [];
2123     my %S; # statistics
2124     while (my $last = pop @$history) {
2125         my $attempts = $last->{attempts} or next;
2126         my $start;
2127         if (@$attempts) {
2128             $start = $attempts->[-1]{start};
2129             if ($#$attempts > 0) {
2130                 for my $i (0..$#$attempts-1) {
2131                     my $url = $attempts->[$i]{url} or next;
2132                     $S{no}{$url}++;
2133                 }
2134             }
2135         } else {
2136             $start = $last->{start};
2137         }
2138         next unless $last->{thesiteurl}; # C-C? bad filenames?
2139         $S{start} = $start;
2140         $S{end} ||= $last->{end};
2141         my $dltime = $last->{end} - $start;
2142         my $dlsize = $last->{filesize} || 0;
2143         my $url = ref $last->{thesiteurl} ? $last->{thesiteurl}->text : $last->{thesiteurl};
2144         my $s = $S{ok}{$url} ||= {};
2145         $s->{n}++;
2146         $s->{dlsize} ||= 0;
2147         $s->{dlsize} += $dlsize/1024;
2148         $s->{dltime} ||= 0;
2149         $s->{dltime} += $dltime;
2150     }
2151     my $res;
2152     for my $url (keys %{$S{ok}}) {
2153         next if $S{ok}{$url}{dltime} == 0; # div by zero
2154         push @{$res->{ok}}, [@{$S{ok}{$url}}{qw(n dlsize dltime)},
2155                              $S{ok}{$url}{dlsize}/$S{ok}{$url}{dltime},
2156                              $url,
2157                             ];
2158     }
2159     for my $url (keys %{$S{no}}) {
2160         push @{$res->{no}}, [$S{no}{$url},
2161                              $url,
2162                             ];
2163     }
2164     my $R = ""; # report
2165     if ($S{start} && $S{end}) {
2166         $R .= sprintf "Log starts: %s\n", $S{start} ? scalar(localtime $S{start}) : "unknown";
2167         $R .= sprintf "Log ends  : %s\n", $S{end}   ? scalar(localtime $S{end})   : "unknown";
2168     }
2169     if ($res->{ok} && @{$res->{ok}}) {
2170         $R .= sprintf "\nSuccessful downloads:
2171    N       kB  secs      kB/s url\n";
2172         my $i = 20;
2173         for (sort { $b->[3] <=> $a->[3] } @{$res->{ok}}) {
2174             $R .= sprintf "%4d %8d %5d %9.1f %s\n", @$_;
2175             last if --$i<=0;
2176         }
2177     }
2178     if ($res->{no} && @{$res->{no}}) {
2179         $R .= sprintf "\nUnsuccessful downloads:\n";
2180         my $i = 20;
2181         for (sort { $b->[0] <=> $a->[0] } @{$res->{no}}) {
2182             $R .= sprintf "%4d %s\n", @$_;
2183             last if --$i<=0;
2184         }
2185     }
2186     $CPAN::Frontend->myprint($R);
2187 }
2188
2189 #-> sub CPAN::Shell::reload ;
2190 sub reload {
2191     my($self,$command,@arg) = @_;
2192     $command ||= "";
2193     $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
2194     if ($command =~ /^cpan$/i) {
2195         my $redef = 0;
2196         chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
2197         my $failed;
2198         my @relo = (
2199                     "CPAN.pm",
2200                     "CPAN/Debug.pm",
2201                     "CPAN/FirstTime.pm",
2202                     "CPAN/HandleConfig.pm",
2203                     "CPAN/Kwalify.pm",
2204                     "CPAN/Queue.pm",
2205                     "CPAN/Reporter/Config.pm",
2206                     "CPAN/Reporter/History.pm",
2207                     "CPAN/Reporter.pm",
2208                     "CPAN/SQLite.pm",
2209                     "CPAN/Tarzip.pm",
2210                     "CPAN/Version.pm",
2211                    );
2212       MFILE: for my $f (@relo) {
2213             next unless exists $INC{$f};
2214             my $p = $f;
2215             $p =~ s/\.pm$//;
2216             $p =~ s|/|::|g;
2217             $CPAN::Frontend->myprint("($p");
2218             local($SIG{__WARN__}) = paintdots_onreload(\$redef);
2219             $self->_reload_this($f) or $failed++;
2220             my $v = eval "$p\::->VERSION";
2221             $CPAN::Frontend->myprint("v$v)");
2222         }
2223         $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
2224         if ($failed) {
2225             my $errors = $failed == 1 ? "error" : "errors";
2226             $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ".
2227                                     "this session.\n");
2228         }
2229     } elsif ($command =~ /^index$/i) {
2230       CPAN::Index->force_reload;
2231     } else {
2232       $CPAN::Frontend->myprint(qq{cpan     re-evals the CPAN modules
2233 index    re-reads the index files\n});
2234     }
2235 }
2236
2237 # reload means only load again what we have loaded before
2238 #-> sub CPAN::Shell::_reload_this ;
2239 sub _reload_this {
2240     my($self,$f,$args) = @_;
2241     CPAN->debug("f[$f]") if $CPAN::DEBUG;
2242     return 1 unless $INC{$f}; # we never loaded this, so we do not
2243                               # reload but say OK
2244     my $pwd = CPAN::anycwd();
2245     CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG;
2246     my($file);
2247     for my $inc (@INC) {
2248         $file = File::Spec->catfile($inc,split /\//, $f);
2249         last if -f $file;
2250         $file = "";
2251     }
2252     CPAN->debug("file[$file]") if $CPAN::DEBUG;
2253     my @inc = @INC;
2254     unless ($file && -f $file) {
2255         # this thingie is not in the INC path, maybe CPAN/MyConfig.pm?
2256         $file = $INC{$f};
2257         unless (CPAN->has_inst("File::Basename")) {
2258             @inc = File::Basename::dirname($file);
2259         } else {
2260             # do we ever need this?
2261             @inc = substr($file,0,-length($f)-1); # bring in back to me!
2262         }
2263     }
2264     CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG;
2265     unless (-f $file) {
2266         $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
2267         return;
2268     }
2269     my $mtime = (stat $file)[9];
2270     if ($reload->{$f}) {
2271     } elsif ($^T < $mtime) {
2272         # since we started the file has changed, force it to be reloaded
2273         $reload->{$f} = -1;
2274     } else {
2275         $reload->{$f} = $mtime;
2276     }
2277     my $must_reload = $mtime != $reload->{$f};
2278     $args ||= {};
2279     $must_reload ||= $args->{reloforce}; # o conf defaults needs this
2280     if ($must_reload) {
2281         my $fh = FileHandle->new($file) or
2282             $CPAN::Frontend->mydie("Could not open $file: $!");
2283         local($/);
2284         local $^W = 1;
2285         my $content = <$fh>;
2286         CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
2287             if $CPAN::DEBUG;
2288         delete $INC{$f};
2289         local @INC = @inc;
2290         eval "require '$f'";
2291         if ($@) {
2292             warn $@;
2293             return;
2294         }
2295         $reload->{$f} = $mtime;
2296     } else {
2297         $CPAN::Frontend->myprint("__unchanged__");
2298     }
2299     return 1;
2300 }
2301
2302 #-> sub CPAN::Shell::mkmyconfig ;
2303 sub mkmyconfig {
2304     my($self, $cpanpm, %args) = @_;
2305     require CPAN::FirstTime;
2306     my $home = CPAN::HandleConfig::home;
2307     $cpanpm = $INC{'CPAN/MyConfig.pm'} ||
2308         File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm");
2309     File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm;
2310     CPAN::HandleConfig::require_myconfig_or_config;
2311     $CPAN::Config ||= {};
2312     $CPAN::Config = {
2313         %$CPAN::Config,
2314         build_dir           =>  undef,
2315         cpan_home           =>  undef,
2316         keep_source_where   =>  undef,
2317         histfile            =>  undef,
2318     };
2319     CPAN::FirstTime::init($cpanpm, %args);
2320 }
2321
2322 #-> sub CPAN::Shell::_binary_extensions ;
2323 sub _binary_extensions {
2324     my($self) = shift @_;
2325     my(@result,$module,%seen,%need,$headerdone);
2326     for $module ($self->expand('Module','/./')) {
2327         my $file  = $module->cpan_file;
2328         next if $file eq "N/A";
2329         next if $file =~ /^Contact Author/;
2330         my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
2331         next if $dist->isa_perl;
2332         next unless $module->xs_file;
2333         local($|) = 1;
2334         $CPAN::Frontend->myprint(".");
2335         push @result, $module;
2336     }
2337 #    print join " | ", @result;
2338     $CPAN::Frontend->myprint("\n");
2339     return @result;
2340 }
2341
2342 #-> sub CPAN::Shell::recompile ;
2343 sub recompile {
2344     my($self) = shift @_;
2345     my($module,@module,$cpan_file,%dist);
2346     @module = $self->_binary_extensions();
2347     for $module (@module) { # we force now and compile later, so we
2348                             # don't do it twice
2349         $cpan_file = $module->cpan_file;
2350         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
2351         $pack->force;
2352         $dist{$cpan_file}++;
2353     }
2354     for $cpan_file (sort keys %dist) {
2355         $CPAN::Frontend->myprint("  CPAN: Recompiling $cpan_file\n\n");
2356         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
2357         $pack->install;
2358         $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
2359                            # stop a package from recompiling,
2360                            # e.g. IO-1.12 when we have perl5.003_10
2361     }
2362 }
2363
2364 #-> sub CPAN::Shell::scripts ;
2365 sub scripts {
2366     my($self, $arg) = @_;
2367     $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");
2368
2369     for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) {
2370         unless ($CPAN::META->has_inst($req)) {
2371             $CPAN::Frontend->mywarn("  $req not available\n");
2372         }
2373     }
2374     my $p = HTML::LinkExtor->new();
2375     my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html";
2376     unless (-f $indexfile) {
2377         $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n");
2378     }
2379     $p->parse_file($indexfile);
2380     my @hrefs;
2381     my $qrarg;
2382     if ($arg =~ s|^/(.+)/$|$1|) {
2383         $qrarg = eval 'qr/$arg/'; # hide construct from 5.004
2384     }
2385     for my $l ($p->links) {
2386         my $tag = shift @$l;
2387         next unless $tag eq "a";
2388         my %att = @$l;
2389         my $href = $att{href};
2390         next unless $href =~ s|^\.\./authors/id/./../||;
2391         if ($arg) {
2392             if ($qrarg) {
2393                 if ($href =~ $qrarg) {
2394                     push @hrefs, $href;
2395                 }
2396             } else {
2397                 if ($href =~ /\Q$arg\E/) {
2398                     push @hrefs, $href;
2399                 }
2400             }
2401         } else {
2402             push @hrefs, $href;
2403         }
2404     }
2405     # now filter for the latest version if there is more than one of a name
2406     my %stems;
2407     for (sort @hrefs) {
2408         my $href = $_;
2409         s/-v?\d.*//;
2410         my $stem = $_;
2411         $stems{$stem} ||= [];
2412         push @{$stems{$stem}}, $href;
2413     }
2414     for (sort keys %stems) {
2415         my $highest;
2416         if (@{$stems{$_}} > 1) {
2417             $highest = List::Util::reduce {
2418                 Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b
2419               } @{$stems{$_}};
2420         } else {
2421             $highest = $stems{$_}[0];
2422         }
2423         $CPAN::Frontend->myprint("$highest\n");
2424     }
2425 }
2426
2427 #-> sub CPAN::Shell::report ;
2428 sub report {
2429     my($self,@args) = @_;
2430     unless ($CPAN::META->has_inst("CPAN::Reporter")) {
2431         $CPAN::Frontend->mydie("CPAN::Reporter not installed; cannot continue");
2432     }
2433     local $CPAN::Config->{test_report} = 1;
2434     $self->force("test",@args); # force is there so that the test be
2435                                 # re-run (as documented)
2436 }
2437
2438 # compare with is_tested
2439 #-> sub CPAN::Shell::install_tested
2440 sub install_tested {
2441     my($self,@some) = @_;
2442     $CPAN::Frontend->mywarn("install_tested() must not be called with arguments.\n"),
2443         return if @some;
2444     CPAN::Index->reload;
2445
2446     for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
2447         my $yaml = "$b.yml";
2448         unless (-f $yaml) {
2449             $CPAN::Frontend->mywarn("No YAML file for $b available, skipping\n");
2450             next;
2451         }
2452         my $yaml_content = CPAN->_yaml_loadfile($yaml);
2453         my $id = $yaml_content->[0]{distribution}{ID};
2454         unless ($id) {
2455             $CPAN::Frontend->mywarn("No ID found in '$yaml', skipping\n");
2456             next;
2457         }
2458         my $do = CPAN::Shell->expandany($id);
2459         unless ($do) {
2460             $CPAN::Frontend->mywarn("Could not expand ID '$id', skipping\n");
2461             next;
2462         }
2463         unless ($do->{build_dir}) {
2464             $CPAN::Frontend->mywarn("Distro '$id' has no build_dir, skipping\n");
2465             next;
2466         }
2467         unless ($do->{build_dir} eq $b) {
2468             $CPAN::Frontend->mywarn("Distro '$id' has build_dir '$do->{build_dir}' but expected '$b', skipping\n");
2469             next;
2470         }
2471         push @some, $do;
2472     }
2473
2474     $CPAN::Frontend->mywarn("No tested distributions found.\n"),
2475         return unless @some;
2476
2477     @some = grep { $_->{make_test} && ! $_->{make_test}->failed } @some;
2478     $CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"),
2479         return unless @some;
2480
2481     # @some = grep { not $_->uptodate } @some;
2482     # $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"),
2483     #     return unless @some;
2484
2485     CPAN->debug("some[@some]");
2486     for my $d (@some) {
2487         my $id = $d->can("pretty_id") ? $d->pretty_id : $d->id;
2488         $CPAN::Frontend->myprint("install_tested: Running for $id\n");
2489         $CPAN::Frontend->mysleep(1);
2490         $self->install($d);
2491     }
2492 }
2493
2494 #-> sub CPAN::Shell::upgrade ;
2495 sub upgrade {
2496     my($self,@args) = @_;
2497     $self->install($self->r(@args));
2498 }
2499
2500 #-> sub CPAN::Shell::_u_r_common ;
2501 sub _u_r_common {
2502     my($self) = shift @_;
2503     my($what) = shift @_;
2504     CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
2505     Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
2506           $what && $what =~ /^[aru]$/;
2507     my(@args) = @_;
2508     @args = '/./' unless @args;
2509     my(@result,$module,%seen,%need,$headerdone,
2510        $version_undefs,$version_zeroes,
2511        @version_undefs,@version_zeroes);
2512     $version_undefs = $version_zeroes = 0;
2513     my $sprintf = "%s%-25s%s %9s %9s  %s\n";
2514     my @expand = $self->expand('Module',@args);
2515     my $expand = scalar @expand;
2516     if (0) { # Looks like noise to me, was very useful for debugging
2517              # for metadata cache
2518         $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
2519     }
2520   MODULE: for $module (@expand) {
2521         my $file  = $module->cpan_file;
2522         next MODULE unless defined $file; # ??
2523         $file =~ s!^./../!!;
2524         my($latest) = $module->cpan_version;
2525         my($inst_file) = $module->inst_file;
2526         my($have);
2527         return if $CPAN::Signal;
2528         if ($inst_file) {
2529             if ($what eq "a") {
2530                 $have = $module->inst_version;
2531             } elsif ($what eq "r") {
2532                 $have = $module->inst_version;
2533                 local($^W) = 0;
2534                 if ($have eq "undef") {
2535                     $version_undefs++;
2536                     push @version_undefs, $module->as_glimpse;
2537                 } elsif (CPAN::Version->vcmp($have,0)==0) {
2538                     $version_zeroes++;
2539                     push @version_zeroes, $module->as_glimpse;
2540                 }
2541                 next MODULE unless CPAN::Version->vgt($latest, $have);
2542 # to be pedantic we should probably say:
2543 #    && !($have eq "undef" && $latest ne "undef" && $latest gt "");
2544 # to catch the case where CPAN has a version 0 and we have a version undef
2545             } elsif ($what eq "u") {
2546                 next MODULE;
2547             }
2548         } else {
2549             if ($what eq "a") {
2550                 next MODULE;
2551             } elsif ($what eq "r") {
2552                 next MODULE;
2553             } elsif ($what eq "u") {
2554                 $have = "-";
2555             }
2556         }
2557         return if $CPAN::Signal; # this is sometimes lengthy
2558         $seen{$file} ||= 0;
2559         if ($what eq "a") {
2560             push @result, sprintf "%s %s\n", $module->id, $have;
2561         } elsif ($what eq "r") {
2562             push @result, $module->id;
2563             next MODULE if $seen{$file}++;
2564         } elsif ($what eq "u") {
2565             push @result, $module->id;
2566             next MODULE if $seen{$file}++;
2567             next MODULE if $file =~ /^Contact/;
2568         }
2569         unless ($headerdone++) {
2570             $CPAN::Frontend->myprint("\n");
2571             $CPAN::Frontend->myprint(sprintf(
2572                                              $sprintf,
2573                                              "",
2574                                              "Package namespace",
2575                                              "",
2576                                              "installed",
2577                                              "latest",
2578                                              "in CPAN file"
2579                                             ));
2580         }
2581         my $color_on = "";
2582         my $color_off = "";
2583         if (
2584             $COLOR_REGISTERED
2585             &&
2586             $CPAN::META->has_inst("Term::ANSIColor")
2587             &&
2588             $module->description
2589            ) {
2590             $color_on = Term::ANSIColor::color("green");
2591             $color_off = Term::ANSIColor::color("reset");
2592         }
2593         $CPAN::Frontend->myprint(sprintf $sprintf,
2594                                  $color_on,
2595                                  $module->id,
2596                                  $color_off,
2597                                  $have,
2598                                  $latest,
2599                                  $file);
2600         $need{$module->id}++;
2601     }
2602     unless (%need) {
2603         if ($what eq "u") {
2604             $CPAN::Frontend->myprint("No modules found for @args\n");
2605         } elsif ($what eq "r") {
2606             $CPAN::Frontend->myprint("All modules are up to date for @args\n");
2607         }
2608     }
2609     if ($what eq "r") {
2610         if ($version_zeroes) {
2611             my $s_has = $version_zeroes > 1 ? "s have" : " has";
2612             $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
2613                                      qq{a version number of 0\n});
2614             if ($CPAN::Config->{show_zero_versions}) {
2615                 local $" = "\t";
2616                 $CPAN::Frontend->myprint(qq{  they are\n\t@version_zeroes\n});
2617                 $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 0' }.
2618                                          qq{to hide them)\n});
2619             } else {
2620                 $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 1' }.
2621                                          qq{to show them)\n});
2622             }
2623         }
2624         if ($version_undefs) {
2625             my $s_has = $version_undefs > 1 ? "s have" : " has";
2626             $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
2627                                      qq{parseable version number\n});
2628             if ($CPAN::Config->{show_unparsable_versions}) {
2629                 local $" = "\t";
2630                 $CPAN::Frontend->myprint(qq{  they are\n\t@version_undefs\n});
2631                 $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 0' }.
2632                                          qq{to hide them)\n});
2633             } else {
2634                 $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 1' }.
2635                                          qq{to show them)\n});
2636             }
2637         }
2638     }
2639     @result;
2640 }
2641
2642 #-> sub CPAN::Shell::r ;
2643 sub r {
2644     shift->_u_r_common("r",@_);
2645 }
2646
2647 #-> sub CPAN::Shell::u ;
2648 sub u {
2649     shift->_u_r_common("u",@_);
2650 }
2651
2652 #-> sub CPAN::Shell::failed ;
2653 sub failed {
2654     my($self,$only_id,$silent) = @_;
2655     my @failed;
2656   DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
2657         my $failed = "";
2658       NAY: for my $nosayer ( # order matters!
2659                             "unwrapped",
2660                             "writemakefile",
2661                             "signature_verify",
2662                             "make",
2663                             "make_test",
2664                             "install",
2665                             "make_clean",
2666                            ) {
2667             next unless exists $d->{$nosayer};
2668             next unless defined $d->{$nosayer};
2669             next unless (
2670                          UNIVERSAL::can($d->{$nosayer},"failed") ?
2671                          $d->{$nosayer}->failed :
2672                          $d->{$nosayer} =~ /^NO/
2673                         );
2674             next NAY if $only_id && $only_id != (
2675                                                  UNIVERSAL::can($d->{$nosayer},"commandid")
2676                                                  ?
2677                                                  $d->{$nosayer}->commandid
2678                                                  :
2679                                                  $CPAN::CurrentCommandId
2680                                                 );
2681             $failed = $nosayer;
2682             last;
2683         }
2684         next DIST unless $failed;
2685         my $id = $d->id;
2686         $id =~ s|^./../||;
2687         #$print .= sprintf(
2688         #                  "  %-45s: %s %s\n",
2689         push @failed,
2690             (
2691              UNIVERSAL::can($d->{$failed},"failed") ?
2692              [
2693               $d->{$failed}->commandid,
2694               $id,
2695               $failed,
2696               $d->{$failed}->text,
2697               $d->{$failed}{TIME}||0,
2698              ] :
2699              [
2700               1,
2701               $id,
2702               $failed,
2703               $d->{$failed},
2704               0,
2705              ]
2706             );
2707     }
2708     my $scope;
2709     if ($only_id) {
2710         $scope = "this command";
2711     } elsif ($CPAN::Index::HAVE_REANIMATED) {
2712         $scope = "this or a previous session";
2713         # it might be nice to have a section for previous session and
2714         # a second for this
2715     } else {
2716         $scope = "this session";
2717     }
2718     if (@failed) {
2719         my $print;
2720         my $debug = 0;
2721         if ($debug) {
2722             $print = join "",
2723                 map { sprintf "%5d %-45s: %s %s\n", @$_ }
2724                     sort { $a->[0] <=> $b->[0] } @failed;
2725         } else {
2726             $print = join "",
2727                 map { sprintf " %-45s: %s %s\n", @$_[1..3] }
2728                     sort {
2729                         $a->[0] <=> $b->[0]
2730                             ||
2731                                 $a->[4] <=> $b->[4]
2732                        } @failed;
2733         }
2734         $CPAN::Frontend->myprint("Failed during $scope:\n$print");
2735     } elsif (!$only_id || !$silent) {
2736         $CPAN::Frontend->myprint("Nothing failed in $scope\n");
2737     }
2738 }
2739
2740 # XXX intentionally undocumented because completely bogus, unportable,
2741 # useless, etc.
2742
2743 #-> sub CPAN::Shell::status ;
2744 sub status {
2745     my($self) = @_;
2746     require Devel::Size;
2747     my $ps = FileHandle->new;
2748     open $ps, "/proc/$$/status";
2749     my $vm = 0;
2750     while (<$ps>) {
2751         next unless /VmSize:\s+(\d+)/;
2752         $vm = $1;
2753         last;
2754     }
2755     $CPAN::Frontend->mywarn(sprintf(
2756                                     "%-27s %6d\n%-27s %6d\n",
2757                                     "vm",
2758                                     $vm,
2759                                     "CPAN::META",
2760                                     Devel::Size::total_size($CPAN::META)/1024,
2761                                    ));
2762     for my $k (sort keys %$CPAN::META) {
2763         next unless substr($k,0,4) eq "read";
2764         warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
2765         for my $k2 (sort keys %{$CPAN::META->{$k}}) {
2766             warn sprintf "  %-25s %6d (keys: %6d)\n",
2767                 $k2,
2768                     Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
2769                           scalar keys %{$CPAN::META->{$k}{$k2}};
2770         }
2771     }
2772 }
2773
2774 # compare with install_tested
2775 #-> sub CPAN::Shell::is_tested
2776 sub is_tested {
2777     my($self) = @_;
2778     CPAN::Index->reload;
2779     for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
2780         my $time;
2781         if ($CPAN::META->{is_tested}{$b}) {
2782             $time = scalar(localtime $CPAN::META->{is_tested}{$b});
2783         } else {
2784             $time = scalar localtime;
2785             $time =~ s/\S/?/g;
2786         }
2787         $CPAN::Frontend->myprint(sprintf "%s %s\n", $time, $b);
2788     }
2789 }
2790
2791 #-> sub CPAN::Shell::autobundle ;
2792 sub autobundle {
2793     my($self) = shift;
2794     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
2795     my(@bundle) = $self->_u_r_common("a",@_);
2796     my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
2797     File::Path::mkpath($todir);
2798     unless (-d $todir) {
2799         $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
2800         return;
2801     }
2802     my($y,$m,$d) =  (localtime)[5,4,3];
2803     $y+=1900;
2804     $m++;
2805     my($c) = 0;
2806     my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
2807     my($to) = File::Spec->catfile($todir,"$me.pm");
2808     while (-f $to) {
2809         $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
2810         $to = File::Spec->catfile($todir,"$me.pm");
2811     }
2812     my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
2813     $fh->print(
2814                "package Bundle::$me;\n\n",
2815                "\$VERSION = '0.01';\n\n",
2816                "1;\n\n",
2817                "__END__\n\n",
2818                "=head1 NAME\n\n",
2819                "Bundle::$me - Snapshot of installation on ",
2820                $Config::Config{'myhostname'},
2821                " on ",
2822                scalar(localtime),
2823                "\n\n=head1 SYNOPSIS\n\n",
2824                "perl -MCPAN -e 'install Bundle::$me'\n\n",
2825                "=head1 CONTENTS\n\n",
2826                join("\n", @bundle),
2827                "\n\n=head1 CONFIGURATION\n\n",
2828                Config->myconfig,
2829                "\n\n=head1 AUTHOR\n\n",
2830                "This Bundle has been generated automatically ",
2831                "by the autobundle routine in CPAN.pm.\n",
2832               );
2833     $fh->close;
2834     $CPAN::Frontend->myprint("\nWrote bundle file
2835     $to\n\n");
2836 }
2837
2838 #-> sub CPAN::Shell::expandany ;
2839 sub expandany {
2840     my($self,$s) = @_;
2841     CPAN->debug("s[$s]") if $CPAN::DEBUG;
2842     if ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory
2843         $s = CPAN::Distribution->normalize($s);
2844         return $CPAN::META->instance('CPAN::Distribution',$s);
2845         # Distributions spring into existence, not expand
2846     } elsif ($s =~ m|^Bundle::|) {
2847         $self->local_bundles; # scanning so late for bundles seems
2848                               # both attractive and crumpy: always
2849                               # current state but easy to forget
2850                               # somewhere
2851         return $self->expand('Bundle',$s);
2852     } else {
2853         return $self->expand('Module',$s)
2854             if $CPAN::META->exists('CPAN::Module',$s);
2855     }
2856     return;
2857 }
2858
2859 #-> sub CPAN::Shell::expand ;
2860 sub expand {
2861     my $self = shift;
2862     my($type,@args) = @_;
2863     CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
2864     my $class = "CPAN::$type";
2865     my $methods = ['id'];
2866     for my $meth (qw(name)) {
2867         next unless $class->can($meth);
2868         push @$methods, $meth;
2869     }
2870     $self->expand_by_method($class,$methods,@args);
2871 }
2872
2873 #-> sub CPAN::Shell::expand_by_method ;
2874 sub expand_by_method {
2875     my $self = shift;
2876     my($class,$methods,@args) = @_;
2877     my($arg,@m);
2878     for $arg (@args) {
2879         my($regex,$command);
2880         if ($arg =~ m|^/(.*)/$|) {
2881             $regex = $1;
2882 # FIXME:  there seem to be some ='s in the author data, which trigger
2883 #         a failure here.  This needs to be contemplated.
2884 #            } elsif ($arg =~ m/=/) {
2885 #                $command = 1;
2886         }
2887         my $obj;
2888         CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
2889                     $class,
2890                     defined $regex ? $regex : "UNDEFINED",
2891                     defined $command ? $command : "UNDEFINED",
2892                    ) if $CPAN::DEBUG;
2893         if (defined $regex) {
2894             if (CPAN::_sqlite_running) {
2895                 $CPAN::SQLite->search($class, $regex);
2896             }
2897             for $obj (
2898                       $CPAN::META->all_objects($class)
2899                      ) {
2900                 unless ($obj && UNIVERSAL::can($obj,"id") && $obj->id) {
2901                     # BUG, we got an empty object somewhere
2902                     require Data::Dumper;
2903                     CPAN->debug(sprintf(
2904                                         "Bug in CPAN: Empty id on obj[%s][%s]",
2905                                         $obj,
2906                                         Data::Dumper::Dumper($obj)
2907                                        )) if $CPAN::DEBUG;
2908                     next;
2909                 }
2910                 for my $method (@$methods) {
2911                     my $match = eval {$obj->$method() =~ /$regex/i};
2912                     if ($@) {
2913                         my($err) = $@ =~ /^(.+) at .+? line \d+\.$/;
2914                         $err ||= $@; # if we were too restrictive above
2915                         $CPAN::Frontend->mydie("$err\n");
2916                     } elsif ($match) {
2917                         push @m, $obj;
2918                         last;
2919                     }
2920                 }
2921             }
2922         } elsif ($command) {
2923             die "equal sign in command disabled (immature interface), ".
2924                 "you can set
2925  ! \$CPAN::Shell::ADVANCED_QUERY=1
2926 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
2927 that may go away anytime.\n"
2928                     unless $ADVANCED_QUERY;
2929             my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
2930             my($matchcrit) = $criterion =~ m/^~(.+)/;
2931             for my $self (
2932                           sort
2933                           {$a->id cmp $b->id}
2934                           $CPAN::META->all_objects($class)
2935                          ) {
2936                 my $lhs = $self->$method() or next; # () for 5.00503
2937                 if ($matchcrit) {
2938                     push @m, $self if $lhs =~ m/$matchcrit/;
2939                 } else {
2940                     push @m, $self if $lhs eq $criterion;
2941                 }
2942             }
2943         } else {
2944             my($xarg) = $arg;
2945             if ( $class eq 'CPAN::Bundle' ) {
2946                 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
2947             } elsif ($class eq "CPAN::Distribution") {
2948                 $xarg = CPAN::Distribution->normalize($arg);
2949             } else {
2950                 $xarg =~ s/:+/::/g;
2951             }
2952             if ($CPAN::META->exists($class,$xarg)) {
2953                 $obj = $CPAN::META->instance($class,$xarg);
2954             } elsif ($CPAN::META->exists($class,$arg)) {
2955                 $obj = $CPAN::META->instance($class,$arg);
2956             } else {
2957                 next;
2958             }
2959             push @m, $obj;
2960         }
2961     }
2962         @m = sort {$a->id cmp $b->id} @m;
2963     if ( $CPAN::DEBUG ) {
2964         my $wantarray = wantarray;
2965         my $join_m = join ",", map {$_->id} @m;
2966         $self->debug("wantarray[$wantarray]join_m[$join_m]");
2967     }
2968     return wantarray ? @m : $m[0];
2969 }
2970
2971 #-> sub CPAN::Shell::format_result ;
2972 sub format_result {
2973     my($self) = shift;
2974     my($type,@args) = @_;
2975     @args = '/./' unless @args;
2976     my(@result) = $self->expand($type,@args);
2977     my $result = @result == 1 ?
2978         $result[0]->as_string :
2979             @result == 0 ?
2980                 "No objects of type $type found for argument @args\n" :
2981                     join("",
2982                          (map {$_->as_glimpse} @result),
2983                          scalar @result, " items found\n",
2984                         );
2985     $result;
2986 }
2987
2988 #-> sub CPAN::Shell::report_fh ;
2989 {
2990     my $installation_report_fh;
2991     my $previously_noticed = 0;
2992
2993     sub report_fh {
2994         return $installation_report_fh if $installation_report_fh;
2995         if ($CPAN::META->has_usable("File::Temp")) {
2996             $installation_report_fh
2997                 = File::Temp->new(
2998                                   dir      => File::Spec->tmpdir,
2999                                   template => 'cpan_install_XXXX',
3000                                   suffix   => '.txt',
3001                                   unlink   => 0,
3002                                  );
3003         }
3004         unless ( $installation_report_fh ) {
3005             warn("Couldn't open installation report file; " .
3006                  "no report file will be generated."
3007                 ) unless $previously_noticed++;
3008         }
3009     }
3010 }
3011
3012
3013 # The only reason for this method is currently to have a reliable
3014 # debugging utility that reveals which output is going through which
3015 # channel. No, I don't like the colors ;-)
3016
3017 # to turn colordebugging on, write
3018 # cpan> o conf colorize_output 1
3019
3020 #-> sub CPAN::Shell::print_ornamented ;
3021 {
3022     my $print_ornamented_have_warned = 0;
3023     sub colorize_output {
3024         my $colorize_output = $CPAN::Config->{colorize_output};
3025         if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
3026             unless ($print_ornamented_have_warned++) {
3027                 # no myprint/mywarn within myprint/mywarn!
3028                 warn "Colorize_output is set to true but Term::ANSIColor is not
3029 installed. To activate colorized output, please install Term::ANSIColor.\n\n";
3030             }
3031             $colorize_output = 0;
3032         }
3033         return $colorize_output;
3034     }
3035 }
3036
3037
3038 #-> sub CPAN::Shell::print_ornamented ;
3039 sub print_ornamented {
3040     my($self,$what,$ornament) = @_;
3041     return unless defined $what;
3042
3043     local $| = 1; # Flush immediately
3044     if ( $CPAN::Be_Silent ) {
3045         print {report_fh()} $what;
3046         return;
3047     }
3048     my $swhat = "$what"; # stringify if it is an object
3049     if ($CPAN::Config->{term_is_latin}) {
3050         # note: deprecated, need to switch to $LANG and $LC_*
3051         # courtesy jhi:
3052         $swhat
3053             =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
3054     }
3055     if ($self->colorize_output) {
3056         if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
3057             # if you want to have this configurable, please file a bugreport
3058             $ornament = $CPAN::Config->{colorize_debug} || "black on_cyan";
3059         }
3060         my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
3061         if ($@) {
3062             print "Term::ANSIColor rejects color[$ornament]: $@\n
3063 Please choose a different color (Hint: try 'o conf init /color/')\n";
3064         }
3065         # GGOLDBACH/Test-GreaterVersion-0.008 broke wthout this
3066         # $trailer construct. We want the newline be the last thing if
3067         # there is a newline at the end ensuring that the next line is
3068         # empty for other players
3069         my $trailer = "";
3070         $trailer = $1 if $swhat =~ s/([\r\n]+)\z//;
3071         print $color_on,
3072             $swhat,
3073                 Term::ANSIColor::color("reset"),
3074                       $trailer;
3075     } else {
3076         print $swhat;
3077     }
3078 }
3079
3080 #-> sub CPAN::Shell::myprint ;
3081
3082 # where is myprint/mywarn/Frontend/etc. documented? Where to use what?
3083 # I think, we send everything to STDOUT and use print for normal/good
3084 # news and warn for news that need more attention. Yes, this is our
3085 # working contract for now.
3086 sub myprint {
3087     my($self,$what) = @_;
3088     $self->print_ornamented($what,
3089                             $CPAN::Config->{colorize_print}||'bold blue on_white',
3090                            );
3091 }
3092
3093 sub optprint {
3094     my($self,$category,$what) = @_;
3095     my $vname = $category . "_verbosity";
3096     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
3097     if (!$CPAN::Config->{$vname}
3098         || $CPAN::Config->{$vname} =~ /^v/
3099        ) {
3100         $CPAN::Frontend->myprint($what);
3101     }
3102 }
3103
3104 #-> sub CPAN::Shell::myexit ;
3105 sub myexit {
3106     my($self,$what) = @_;
3107     $self->myprint($what);
3108     exit;
3109 }
3110
3111 #-> sub CPAN::Shell::mywarn ;
3112 sub mywarn {
3113     my($self,$what) = @_;
3114     $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
3115 }
3116
3117 # only to be used for shell commands
3118 #-> sub CPAN::Shell::mydie ;
3119 sub mydie {
3120     my($self,$what) = @_;
3121     $self->mywarn($what);
3122
3123     # If it is the shell, we want the following die to be silent,
3124     # but if it is not the shell, we would need a 'die $what'. We need
3125     # to take care that only shell commands use mydie. Is this
3126     # possible?
3127
3128     die "\n";
3129 }
3130
3131 # sub CPAN::Shell::colorable_makemaker_prompt ;
3132 sub colorable_makemaker_prompt {
3133     my($foo,$bar) = @_;
3134     if (CPAN::Shell->colorize_output) {
3135         my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
3136         my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
3137         print $color_on;
3138     }
3139     my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
3140     if (CPAN::Shell->colorize_output) {
3141         print Term::ANSIColor::color('reset');
3142     }
3143     return $ans;
3144 }
3145
3146 # use this only for unrecoverable errors!
3147 #-> sub CPAN::Shell::unrecoverable_error ;
3148 sub unrecoverable_error {
3149     my($self,$what) = @_;
3150     my @lines = split /\n/, $what;
3151     my $longest = 0;
3152     for my $l (@lines) {
3153         $longest = length $l if length $l > $longest;
3154     }
3155     $longest = 62 if $longest > 62;
3156     for my $l (@lines) {
3157         if ($l =~ /^\s*$/) {
3158             $l = "\n";
3159             next;
3160         }
3161         $l = "==> $l";
3162         if (length $l < 66) {
3163             $l = pack "A66 A*", $l, "<==";
3164         }
3165         $l .= "\n";
3166     }
3167     unshift @lines, "\n";
3168     $self->mydie(join "", @lines);
3169 }
3170
3171 #-> sub CPAN::Shell::mysleep ;
3172 sub mysleep {
3173     my($self, $sleep) = @_;
3174     if (CPAN->has_inst("Time::HiRes")) {
3175         Time::HiRes::sleep($sleep);
3176     } else {
3177         sleep($sleep < 1 ? 1 : int($sleep + 0.5));
3178     }
3179 }
3180
3181 #-> sub CPAN::Shell::setup_output ;
3182 sub setup_output {
3183     return if -t STDOUT;
3184     my $odef = select STDERR;
3185     $| = 1;
3186     select STDOUT;
3187     $| = 1;
3188     select $odef;
3189 }
3190
3191 #-> sub CPAN::Shell::rematein ;
3192 # RE-adme||MA-ke||TE-st||IN-stall : nearly everything runs through here
3193 sub rematein {
3194     my $self = shift;
3195     my($meth,@some) = @_;
3196     my @pragma;
3197     while($meth =~ /^(ff?orce|notest)$/) {
3198         push @pragma, $meth;
3199         $meth = shift @some or
3200             $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
3201                                    "cannot continue");
3202     }
3203     setup_output();
3204     CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
3205
3206     # Here is the place to set "test_count" on all involved parties to
3207     # 0. We then can pass this counter on to the involved
3208     # distributions and those can refuse to test if test_count > X. In
3209     # the first stab at it we could use a 1 for "X".
3210
3211     # But when do I reset the distributions to start with 0 again?
3212     # Jost suggested to have a random or cycling interaction ID that
3213     # we pass through. But the ID is something that is just left lying
3214     # around in addition to the counter, so I'd prefer to set the
3215     # counter to 0 now, and repeat at the end of the loop. But what
3216     # about dependencies? They appear later and are not reset, they
3217     # enter the queue but not its copy. How do they get a sensible
3218     # test_count?
3219
3220     # With configure_requires, "get" is vulnerable in recursion.
3221
3222     my $needs_recursion_protection = "get|make|test|install";
3223
3224     # construct the queue
3225     my($s,@s,@qcopy);
3226   STHING: foreach $s (@some) {
3227         my $obj;
3228         if (ref $s) {
3229             CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
3230             $obj = $s;
3231         } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
3232         } elsif ($s =~ m|^/|) { # looks like a regexp
3233             if (substr($s,-1,1) eq ".") {
3234                 $obj = CPAN::Shell->expandany($s);
3235             } else {
3236                 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
3237                                         "not supported.\nRejecting argument '$s'\n");
3238                 $CPAN::Frontend->mysleep(2);
3239                 next;
3240             }
3241         } elsif ($meth eq "ls") {
3242             $self->globls($s,\@pragma);
3243             next STHING;
3244         } else {
3245             CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
3246             $obj = CPAN::Shell->expandany($s);
3247         }
3248         if (0) {
3249         } elsif (ref $obj) {
3250             if ($meth =~ /^($needs_recursion_protection)$/) {
3251                 # it would be silly to check for recursion for look or dump
3252                 # (we are in CPAN::Shell::rematein)
3253                 CPAN->debug("Going to test against recursion") if $CPAN::DEBUG;
3254                 eval {  $obj->color_cmd_tmps(0,1); };
3255                 if ($@) {
3256                     if (ref $@
3257                         and $@->isa("CPAN::Exception::RecursiveDependency")) {
3258                         $CPAN::Frontend->mywarn($@);
3259                     } else {
3260                         if (0) {
3261                             require Carp;
3262                             Carp::confess(sprintf "DEBUG: \$\@[%s]ref[%s]", $@, ref $@);
3263                         }
3264                         die;
3265                     }
3266                 }
3267             }
3268             CPAN::Queue->queue_item(qmod => $obj->id, reqtype => "c");
3269             push @qcopy, $obj;
3270         } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
3271             $obj = $CPAN::META->instance('CPAN::Author',uc($s));
3272             if ($meth =~ /^(dump|ls|reports)$/) {
3273                 $obj->$meth();
3274             } else {
3275                 $CPAN::Frontend->mywarn(
3276                                         join "",
3277                                         "Don't be silly, you can't $meth ",
3278                                         $obj->fullname,
3279                                         " ;-)\n"
3280                                        );
3281                 $CPAN::Frontend->mysleep(2);
3282             }
3283         } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
3284             CPAN::InfoObj->dump($s);
3285         } else {
3286             $CPAN::Frontend
3287                 ->mywarn(qq{Warning: Cannot $meth $s, }.
3288                          qq{don't know what it is.
3289 Try the command
3290
3291     i /$s/
3292
3293 to find objects with matching identifiers.
3294 });
3295             $CPAN::Frontend->mysleep(2);
3296         }
3297     }
3298
3299     # queuerunner (please be warned: when I started to change the
3300     # queue to hold objects instead of names, I made one or two
3301     # mistakes and never found which. I reverted back instead)
3302     while (my $q = CPAN::Queue->first) {
3303         my $obj;
3304         my $s = $q->as_string;
3305         my $reqtype = $q->reqtype || "";
3306         $obj = CPAN::Shell->expandany($s);
3307         unless ($obj) {
3308             # don't know how this can happen, maybe we should panic,
3309             # but maybe we get a solution from the first user who hits
3310             # this unfortunate exception?
3311             $CPAN::Frontend->mywarn("Warning: Could not expand string '$s' ".
3312                                     "to an object. Skipping.\n");
3313             $CPAN::Frontend->mysleep(5);
3314             CPAN::Queue->delete_first($s);
3315             next;
3316         }
3317         $obj->{reqtype} ||= "";
3318         {
3319             # force debugging because CPAN::SQLite somehow delivers us
3320             # an empty object;
3321
3322             # local $CPAN::DEBUG = 1024; # Shell; probably fixed now
3323
3324             CPAN->debug("s[$s]obj-reqtype[$obj->{reqtype}]".
3325                         "q-reqtype[$reqtype]") if $CPAN::DEBUG;
3326         }
3327         if ($obj->{reqtype}) {
3328             if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
3329                 $obj->{reqtype} = $reqtype;
3330                 if (
3331                     exists $obj->{install}
3332                     &&
3333                     (
3334                      UNIVERSAL::can($obj->{install},"failed") ?
3335                      $obj->{install}->failed :
3336                      $obj->{install} =~ /^NO/
3337                     )
3338                    ) {
3339                     delete $obj->{install};
3340                     $CPAN::Frontend->mywarn
3341                         ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
3342                 }
3343             }
3344         } else {
3345             $obj->{reqtype} = $reqtype;
3346         }
3347
3348         for my $pragma (@pragma) {
3349             if ($pragma
3350                 &&
3351                 $obj->can($pragma)) {
3352                 $obj->$pragma($meth);
3353             }
3354         }
3355         if (UNIVERSAL::can($obj, 'called_for')) {
3356             $obj->called_for($s);
3357         }
3358         CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
3359                     qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
3360
3361         push @qcopy, $obj;
3362         if ($meth =~ /^(report)$/) { # they came here with a pragma?
3363             $self->$meth($obj);
3364         } elsif (! UNIVERSAL::can($obj,$meth)) {
3365             # Must never happen
3366             my $serialized = "";
3367             if (0) {
3368             } elsif ($CPAN::META->has_inst("YAML::Syck")) {
3369                 $serialized = YAML::Syck::Dump($obj);
3370             } elsif ($CPAN::META->has_inst("YAML")) {
3371                 $serialized = YAML::Dump($obj);
3372             } elsif ($CPAN::META->has_inst("Data::Dumper")) {
3373                 $serialized = Data::Dumper::Dumper($obj);
3374             } else {
3375                 require overload;
3376                 $serialized = overload::StrVal($obj);
3377             }
3378             CPAN->debug("Going to panic. meth[$meth]s[$s]") if $CPAN::DEBUG;
3379             $CPAN::Frontend->mydie("Panic: obj[$serialized] cannot meth[$meth]");
3380         } elsif ($obj->$meth()) {
3381             CPAN::Queue->delete($s);
3382             CPAN->debug("From queue deleted. meth[$meth]s[$s]") if $CPAN::DEBUG;
3383         } else {
3384             CPAN->debug("Failed. pragma[@pragma]meth[$meth]") if $CPAN::DEBUG;
3385         }
3386
3387         $obj->undelay;
3388         for my $pragma (@pragma) {
3389             my $unpragma = "un$pragma";
3390             if ($obj->can($unpragma)) {
3391                 $obj->$unpragma();
3392             }
3393         }
3394         CPAN::Queue->delete_first($s);
3395     }
3396     if ($meth =~ /^($needs_recursion_protection)$/) {
3397         for my $obj (@qcopy) {
3398             $obj->color_cmd_tmps(0,0);
3399         }
3400     }
3401 }
3402
3403 #-> sub CPAN::Shell::recent ;
3404 sub recent {
3405   my($self) = @_;
3406   if ($CPAN::META->has_inst("XML::LibXML")) {
3407       my $url = $CPAN::Defaultrecent;
3408       $CPAN::Frontend->myprint("Going to fetch '$url'\n");
3409       unless ($CPAN::META->has_usable("LWP")) {
3410           $CPAN::Frontend->mydie("LWP not installed; cannot continue");
3411       }
3412       CPAN::LWP::UserAgent->config;
3413       my $Ua;
3414       eval { $Ua = CPAN::LWP::UserAgent->new; };
3415       if ($@) {
3416           $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
3417       }
3418       my $resp = $Ua->get($url);
3419       unless ($resp->is_success) {
3420           $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
3421       }
3422       $CPAN::Frontend->myprint("DONE\n\n");
3423       my $xml = XML::LibXML->new->parse_string($resp->content);
3424       if (0) {
3425           my $s = $xml->serialize(2);
3426           $s =~ s/\n\s*\n/\n/g;
3427           $CPAN::Frontend->myprint($s);
3428           return;
3429       }
3430       my @distros;
3431       if ($url =~ /winnipeg/) {
3432           my $pubdate = $xml->findvalue("/rss/channel/pubDate");
3433           $CPAN::Frontend->myprint("    pubDate: $pubdate\n\n");
3434           for my $eitem ($xml->findnodes("/rss/channel/item")) {
3435               my $distro = $eitem->findvalue("enclosure/\@url");
3436               $distro =~ s|.*?/authors/id/./../||;
3437               my $size   = $eitem->findvalue("enclosure/\@length");
3438               my $desc   = $eitem->findvalue("description");
3439 \0              $desc =~ s/.+? - //;
3440               $CPAN::Frontend->myprint("$distro [$size b]\n    $desc\n");
3441               push @distros, $distro;
3442           }
3443       } elsif ($url =~ /search.*uploads.rdf/) {
3444           # xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
3445           # xmlns="http://purl.org/rss/1.0/"
3446           # xmlns:taxo="http://purl.org/rss/1.0/modules/taxonomy/"
3447           # xmlns:dc="http://purl.org/dc/elements/1.1/"
3448           # xmlns:syn="http://purl.org/rss/1.0/modules/syndication/"
3449           # xmlns:admin="http://webns.net/mvcb/"
3450
3451
3452           my $dc_date = $xml->findvalue("//*[local-name(.) = 'RDF']/*[local-name(.) = 'channel']/*[local-name(.) = 'date']");
3453           $CPAN::Frontend->myprint("    dc:date: $dc_date\n\n");
3454           my $finish_eitem = 0;
3455           local $SIG{INT} = sub { $finish_eitem = 1 };
3456         EITEM: for my $eitem ($xml->findnodes("//*[local-name(.) = 'RDF']/*[local-name(.) = 'item']")) {
3457               my $distro = $eitem->findvalue("\@rdf:about");
3458               $distro =~ s|.*~||; # remove up to the tilde before the name
3459               $distro =~ s|/$||; # remove trailing slash
3460               $distro =~ s|([^/]+)|\U$1\E|; # upcase the name
3461               my $author = uc $1 or die "distro[$distro] without author, cannot continue";
3462               my $desc   = $eitem->findvalue("*[local-name(.) = 'description']");
3463               my $i = 0;
3464             SUBDIRTEST: while () {
3465                   last SUBDIRTEST if ++$i >= 6; # half a dozen must do!
3466                   if (my @ret = $self->globls("$distro*")) {
3467                       @ret = grep {$_->[2] !~ /meta/} @ret;
3468                       @ret = grep {length $_->[2]} @ret;
3469                       if (@ret) {
3470                           $distro = "$author/$ret[0][2]";
3471                           last SUBDIRTEST;
3472                       }
3473                   }
3474                   $distro =~ s|/|/*/|; # allow it to reside in a subdirectory
3475               }
3476
3477               next EITEM if $distro =~ m|\*|; # did not find the thing
3478               $CPAN::Frontend->myprint("____$desc\n");
3479               push @distros, $distro;
3480               last EITEM if $finish_eitem;
3481           }
3482       }
3483       return \@distros;
3484   } else {
3485       # deprecated old version
3486       $CPAN::Frontend->mydie("no XML::LibXML installed, cannot continue\n");
3487   }
3488 }
3489
3490 #-> sub CPAN::Shell::smoke ;
3491 sub smoke {
3492     my($self) = @_;
3493     my $distros = $self->recent;
3494   DISTRO: for my $distro (@$distros) {
3495         $CPAN::Frontend->myprint(sprintf "Going to download and test '$distro'\n");
3496         {
3497             my $skip = 0;
3498             local $SIG{INT} = sub { $skip = 1 };
3499             for (0..9) {
3500                 $CPAN::Frontend->myprint(sprintf "\r%2d (Hit ^C to skip)", 10-$_);
3501                 sleep 1;
3502                 if ($skip) {
3503                     $CPAN::Frontend->myprint(" skipped\n");
3504                     next DISTRO;
3505                 }
3506             }
3507         }
3508         $CPAN::Frontend->myprint("\r  \n"); # leave the dirty line with a newline
3509         $self->test($distro);
3510     }
3511 }
3512
3513 {
3514     # set up the dispatching methods
3515     no strict "refs";
3516     for my $command (qw(
3517                         clean
3518                         cvs_import
3519                         dump
3520                         force
3521                         fforce
3522                         get
3523                         install
3524                         look
3525                         ls
3526                         make
3527                         notest
3528                         perldoc
3529                         readme
3530                         reports
3531                         test
3532                        )) {
3533         *$command = sub { shift->rematein($command, @_); };
3534     }
3535 }
3536
3537 package CPAN::LWP::UserAgent;
3538 use strict;
3539
3540 sub config {
3541     return if $SETUPDONE;
3542     if ($CPAN::META->has_usable('LWP::UserAgent')) {
3543         require LWP::UserAgent;
3544         @ISA = qw(Exporter LWP::UserAgent);
3545         $SETUPDONE++;
3546     } else {
3547         $CPAN::Frontend->mywarn("  LWP::UserAgent not available\n");
3548     }
3549 }
3550
3551 sub get_basic_credentials {
3552     my($self, $realm, $uri, $proxy) = @_;
3553     if ($USER && $PASSWD) {
3554         return ($USER, $PASSWD);
3555     }
3556     if ( $proxy ) {
3557         ($USER,$PASSWD) = $self->get_proxy_credentials();
3558     } else {
3559         ($USER,$PASSWD) = $self->get_non_proxy_credentials();
3560     }
3561     return($USER,$PASSWD);
3562 }
3563
3564 sub get_proxy_credentials {
3565     my $self = shift;
3566     my ($user, $password);
3567     if ( defined $CPAN::Config->{proxy_user} &&
3568          defined $CPAN::Config->{proxy_pass}) {
3569         $user = $CPAN::Config->{proxy_user};
3570         $password = $CPAN::Config->{proxy_pass};
3571         return ($user, $password);
3572     }
3573     my $username_prompt = "\nProxy authentication needed!
3574  (Note: to permanently configure username and password run
3575    o conf proxy_user your_username
3576    o conf proxy_pass your_password
3577      )\nUsername:";
3578     ($user, $password) =
3579         _get_username_and_password_from_user($username_prompt);
3580     return ($user,$password);
3581 }
3582
3583 sub get_non_proxy_credentials {
3584     my $self = shift;
3585     my ($user,$password);
3586     if ( defined $CPAN::Config->{username} &&
3587          defined $CPAN::Config->{password}) {
3588         $user = $CPAN::Config->{username};
3589         $password = $CPAN::Config->{password};
3590         return ($user, $password);
3591     }
3592     my $username_prompt = "\nAuthentication needed!
3593      (Note: to permanently configure username and password run
3594        o conf username your_username
3595        o conf password your_password
3596      )\nUsername:";
3597
3598     ($user, $password) =
3599         _get_username_and_password_from_user($username_prompt);
3600     return ($user,$password);
3601 }
3602
3603 sub _get_username_and_password_from_user {
3604     my $username_message = shift;
3605     my ($username,$password);
3606
3607     ExtUtils::MakeMaker->import(qw(prompt));
3608     $username = prompt($username_message);
3609         if ($CPAN::META->has_inst("Term::ReadKey")) {
3610             Term::ReadKey::ReadMode("noecho");
3611         }
3612     else {
3613         $CPAN::Frontend->mywarn(
3614             "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"
3615         );
3616     }
3617     $password = prompt("Password:");
3618
3619         if ($CPAN::META->has_inst("Term::ReadKey")) {
3620             Term::ReadKey::ReadMode("restore");
3621         }
3622         $CPAN::Frontend->myprint("\n\n");
3623     return ($username,$password);
3624 }
3625
3626 # mirror(): Its purpose is to deal with proxy authentication. When we
3627 # call SUPER::mirror, we relly call the mirror method in
3628 # LWP::UserAgent. LWP::UserAgent will then call
3629 # $self->get_basic_credentials or some equivalent and this will be
3630 # $self->dispatched to our own get_basic_credentials method.
3631
3632 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3633
3634 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3635 # although we have gone through our get_basic_credentials, the proxy
3636 # server refuses to connect. This could be a case where the username or
3637 # password has changed in the meantime, so I'm trying once again without
3638 # $USER and $PASSWD to give the get_basic_credentials routine another
3639 # chance to set $USER and $PASSWD.
3640
3641 # mirror(): Its purpose is to deal with proxy authentication. When we
3642 # call SUPER::mirror, we relly call the mirror method in
3643 # LWP::UserAgent. LWP::UserAgent will then call
3644 # $self->get_basic_credentials or some equivalent and this will be
3645 # $self->dispatched to our own get_basic_credentials method.
3646
3647 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3648
3649 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3650 # although we have gone through our get_basic_credentials, the proxy
3651 # server refuses to connect. This could be a case where the username or
3652 # password has changed in the meantime, so I'm trying once again without
3653 # $USER and $PASSWD to give the get_basic_credentials routine another
3654 # chance to set $USER and $PASSWD.
3655
3656 sub mirror {
3657     my($self,$url,$aslocal) = @_;
3658     my $result = $self->SUPER::mirror($url,$aslocal);
3659     if ($result->code == 407) {
3660         undef $USER;
3661         undef $PASSWD;
3662         $result = $self->SUPER::mirror($url,$aslocal);
3663     }
3664     $result;
3665 }
3666
3667 package CPAN::FTP;
3668 use strict;
3669
3670 #-> sub CPAN::FTP::ftp_statistics
3671 # if they want to rewrite, they need to pass in a filehandle
3672 sub _ftp_statistics {
3673     my($self,$fh) = @_;
3674     my $locktype = $fh ? LOCK_EX : LOCK_SH;
3675     $fh ||= FileHandle->new;
3676     my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3677     open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!");
3678     my $sleep = 1;
3679     my $waitstart;
3680     while (!CPAN::_flock($fh, $locktype|LOCK_NB)) {
3681         $waitstart ||= localtime();
3682         if ($sleep>3) {
3683             $CPAN::Frontend->mywarn("Waiting for a read lock on '$file' (since $waitstart)\n");
3684         }
3685         $CPAN::Frontend->mysleep($sleep);
3686         if ($sleep <= 3) {
3687             $sleep+=0.33;
3688         } elsif ($sleep <=6) {
3689             $sleep+=0.11;
3690         }
3691     }
3692     my $stats = eval { CPAN->_yaml_loadfile($file); };
3693     if ($@) {
3694         if (ref $@) {
3695             if (ref $@ eq "CPAN::Exception::yaml_not_installed") {
3696                 $CPAN::Frontend->myprint("Warning (usually harmless): $@");
3697                 return;
3698             } elsif (ref $@ eq "CPAN::Exception::yaml_process_error") {
3699                 $CPAN::Frontend->mydie($@);
3700             }
3701         } else {
3702             $CPAN::Frontend->mydie($@);
3703         }
3704     }
3705     return $stats->[0];
3706 }
3707
3708 #-> sub CPAN::FTP::_mytime
3709 sub _mytime () {
3710     if (CPAN->has_inst("Time::HiRes")) {
3711         return Time::HiRes::time();
3712     } else {
3713         return time;
3714     }
3715 }
3716
3717 #-> sub CPAN::FTP::_new_stats
3718 sub _new_stats {
3719     my($self,$file) = @_;
3720     my $ret = {
3721                file => $file,
3722                attempts => [],
3723                start => _mytime,
3724               };
3725     $ret;
3726 }
3727
3728 #-> sub CPAN::FTP::_add_to_statistics
3729 sub _add_to_statistics {
3730     my($self,$stats) = @_;
3731     my $yaml_module = CPAN::_yaml_module;
3732     $self->debug("yaml_module[$yaml_module]") if $CPAN::DEBUG;
3733     if ($CPAN::META->has_inst($yaml_module)) {
3734         $stats->{thesiteurl} = $ThesiteURL;
3735         if (CPAN->has_inst("Time::HiRes")) {
3736             $stats->{end} = Time::HiRes::time();
3737         } else {
3738             $stats->{end} = time;
3739         }
3740         my $fh = FileHandle->new;
3741         my $time = time;
3742         my $sdebug = 0;
3743         my @debug;
3744         @debug = $time if $sdebug;
3745         my $fullstats = $self->_ftp_statistics($fh);
3746         close $fh;
3747         $fullstats->{history} ||= [];
3748         push @debug, scalar @{$fullstats->{history}} if $sdebug;
3749         push @debug, time if $sdebug;
3750         push @{$fullstats->{history}}, $stats;
3751         # arbitrary hardcoded constants until somebody demands to have
3752         # them settable; YAML.pm 0.62 is unacceptably slow with 999;
3753         # YAML::Syck 0.82 has no noticable performance problem with 999;
3754         while (
3755                @{$fullstats->{history}} > 99
3756                || $time - $fullstats->{history}[0]{start} > 14*86400
3757               ) {
3758             shift @{$fullstats->{history}}
3759         }
3760         push @debug, scalar @{$fullstats->{history}} if $sdebug;
3761         push @debug, time if $sdebug;
3762         push @debug, scalar localtime($fullstats->{history}[0]{start}) if $sdebug;
3763         # need no eval because if this fails, it is serious
3764         my $sfile = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3765         CPAN->_yaml_dumpfile("$sfile.$$",$fullstats);
3766         if ( $sdebug ) {
3767             local $CPAN::DEBUG = 512; # FTP
3768             push @debug, time;
3769             CPAN->debug(sprintf("DEBUG history: before_read[%d]before[%d]at[%d]".
3770                                 "after[%d]at[%d]oldest[%s]dumped backat[%d]",
3771                                 @debug,
3772                                ));
3773         }
3774         # Win32 cannot rename a file to an existing filename
3775         unlink($sfile) if ($^O eq 'MSWin32');
3776         rename "$sfile.$$", $sfile
3777             or $CPAN::Frontend->mydie("Could not rename '$sfile.$$' to '$sfile': $!\n");
3778     }
3779 }
3780
3781 # if file is CHECKSUMS, suggest the place where we got the file to be
3782 # checked from, maybe only for young files?
3783 #-> sub CPAN::FTP::_recommend_url_for
3784 sub _recommend_url_for {
3785     my($self, $file) = @_;
3786     my $urllist = $self->_get_urllist;
3787     if ($file =~ s|/CHECKSUMS(.gz)?$||) {
3788         my $fullstats = $self->_ftp_statistics();
3789         my $history = $fullstats->{history} || [];
3790         while (my $last = pop @$history) {
3791             last if $last->{end} - time > 3600; # only young results are interesting
3792             next unless $last->{file}; # dirname of nothing dies!
3793             next unless $file eq File::Basename::dirname($last->{file});
3794             return $last->{thesiteurl};
3795         }
3796     }
3797     if ($CPAN::Config->{randomize_urllist}
3798         &&
3799         rand(1) < $CPAN::Config->{randomize_urllist}
3800        ) {
3801         $urllist->[int rand scalar @$urllist];
3802     } else {
3803         return ();
3804     }
3805 }
3806
3807 #-> sub CPAN::FTP::_get_urllist
3808 sub _get_urllist {
3809     my($self) = @_;
3810     $CPAN::Config->{urllist} ||= [];
3811     unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
3812         $CPAN::Frontend->mywarn("Malformed urllist; ignoring.  Configuration file corrupt?\n");
3813         $CPAN::Config->{urllist} = [];
3814     }
3815     my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}};
3816     for my $u (@urllist) {
3817         CPAN->debug("u[$u]") if $CPAN::DEBUG;
3818         if (UNIVERSAL::can($u,"text")) {
3819             $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
3820         } else {
3821             $u .= "/" unless substr($u,-1) eq "/";
3822             $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
3823         }
3824     }
3825     \@urllist;
3826 }
3827
3828 #-> sub CPAN::FTP::ftp_get ;
3829 sub ftp_get {
3830     my($class,$host,$dir,$file,$target) = @_;
3831     $class->debug(
3832                   qq[Going to fetch file [$file] from dir [$dir]
3833         on host [$host] as local [$target]\n]
3834                  ) if $CPAN::DEBUG;
3835     my $ftp = Net::FTP->new($host);
3836     unless ($ftp) {
3837         $CPAN::Frontend->mywarn("  Could not connect to host '$host' with Net::FTP\n");
3838         return;
3839     }
3840     return 0 unless defined $ftp;
3841     $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
3842     $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
3843     unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ) {
3844         my $msg = $ftp->message;
3845         $CPAN::Frontend->mywarn("  Couldn't login on $host: $msg");
3846         return;
3847     }
3848     unless ( $ftp->cwd($dir) ) {
3849         my $msg = $ftp->message;
3850         $CPAN::Frontend->mywarn("  Couldn't cwd $dir: $msg");
3851         return;
3852     }
3853     $ftp->binary;
3854     $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
3855     unless ( $ftp->get($file,$target) ) {
3856         my $msg = $ftp->message;
3857         $CPAN::Frontend->mywarn("  Couldn't fetch $file from $host: $msg");
3858         return;
3859     }
3860     $ftp->quit; # it's ok if this fails
3861     return 1;
3862 }
3863
3864 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
3865
3866  # > *** /install/perl/live/lib/CPAN.pm-        Wed Sep 24 13:08:48 1997
3867  # > --- /tmp/cp        Wed Sep 24 13:26:40 1997
3868  # > ***************
3869  # > *** 1562,1567 ****
3870  # > --- 1562,1580 ----
3871  # >       return 1 if substr($url,0,4) eq "file";
3872  # >       return 1 unless $url =~ m|://([^/]+)|;
3873  # >       my $host = $1;
3874  # > +     my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
3875  # > +     if ($proxy) {
3876  # > +         $proxy =~ m|://([^/:]+)|;
3877  # > +         $proxy = $1;
3878  # > +         my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
3879  # > +         if ($noproxy) {
3880  # > +             if ($host !~ /$noproxy$/) {
3881  # > +                 $host = $proxy;
3882  # > +             }
3883  # > +         } else {
3884  # > +             $host = $proxy;
3885  # > +         }
3886  # > +     }
3887  # >       require Net::Ping;
3888  # >       return 1 unless $Net::Ping::VERSION >= 2;
3889  # >       my $p;
3890
3891
3892 #-> sub CPAN::FTP::localize ;
3893 sub localize {
3894     my($self,$file,$aslocal,$force) = @_;
3895     $force ||= 0;
3896     Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
3897         unless defined $aslocal;
3898     $self->debug("file[$file] aslocal[$aslocal] force[$force]")
3899         if $CPAN::DEBUG;
3900
3901     if ($^O eq 'MacOS') {
3902         # Comment by AK on 2000-09-03: Uniq short filenames would be
3903         # available in CHECKSUMS file
3904         my($name, $path) = File::Basename::fileparse($aslocal, '');
3905         if (length($name) > 31) {
3906             $name =~ s/(
3907                         \.(
3908                            readme(\.(gz|Z))? |
3909                            (tar\.)?(gz|Z) |
3910                            tgz |
3911                            zip |
3912                            pm\.(gz|Z)
3913                           )
3914                        )$//x;
3915             my $suf = $1;
3916             my $size = 31 - length($suf);
3917             while (length($name) > $size) {
3918                 chop $name;
3919             }
3920             $name .= $suf;
3921             $aslocal = File::Spec->catfile($path, $name);
3922         }
3923     }
3924
3925     if (-f $aslocal && -r _ && !($force & 1)) {
3926         my $size;
3927         if ($size = -s $aslocal) {
3928             $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
3929             return $aslocal;
3930         } else {
3931             # empty file from a previous unsuccessful attempt to download it
3932             unlink $aslocal or
3933                 $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
3934                                        "could not remove.");
3935         }
3936     }
3937     my($maybe_restore) = 0;
3938     if (-f $aslocal) {
3939         rename $aslocal, "$aslocal.bak$$";
3940         $maybe_restore++;
3941     }
3942
3943     my($aslocal_dir) = File::Basename::dirname($aslocal);
3944     $self->mymkpath($aslocal_dir); # too early for file URLs / RT #28438
3945     # Inheritance is not easier to manage than a few if/else branches
3946     if ($CPAN::META->has_usable('LWP::UserAgent')) {
3947         unless ($Ua) {
3948             CPAN::LWP::UserAgent->config;
3949             eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
3950             if ($@) {
3951                 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
3952                     if $CPAN::DEBUG;
3953             } else {
3954                 my($var);
3955                 $Ua->proxy('ftp',  $var)
3956                     if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
3957                 $Ua->proxy('http', $var)
3958                     if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
3959                 $Ua->no_proxy($var)
3960                     if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
3961             }
3962         }
3963     }
3964     for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
3965         $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
3966     }
3967
3968     # Try the list of urls for each single object. We keep a record
3969     # where we did get a file from
3970     my(@reordered,$last);
3971     my $ccurllist = $self->_get_urllist;
3972     $last = $#$ccurllist;
3973     if ($force & 2) { # local cpans probably out of date, don't reorder
3974         @reordered = (0..$last);
3975     } else {
3976         @reordered =
3977             sort {
3978                 (substr($ccurllist->[$b],0,4) eq "file")
3979                     <=>
3980                 (substr($ccurllist->[$a],0,4) eq "file")
3981                     or
3982                 defined($ThesiteURL)
3983                     and
3984                 ($ccurllist->[$b] eq $ThesiteURL)
3985                     <=>
3986                 ($ccurllist->[$a] eq $ThesiteURL)
3987             } 0..$last;
3988     }
3989     my(@levels);
3990     $Themethod ||= "";
3991     $self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG;
3992     my @all_levels = (
3993                       ["dleasy",   "file"],
3994                       ["dleasy"],
3995                       ["dlhard"],
3996                       ["dlhardest"],
3997                       ["dleasy",   "http","defaultsites"],
3998                       ["dlhard",   "http","defaultsites"],
3999                       ["dleasy",   "ftp", "defaultsites"],
4000                       ["dlhard",   "ftp", "defaultsites"],
4001                       ["dlhardest","",    "defaultsites"],
4002                      );
4003     if ($Themethod) {
4004         @levels = grep {$_->[0] eq $Themethod} @all_levels;
4005         push @levels, grep {$_->[0] ne $Themethod} @all_levels;
4006     } else {
4007         @levels = @all_levels;
4008     }
4009     @levels = qw/dleasy/ if $^O eq 'MacOS';
4010     my($levelno);
4011     local $ENV{FTP_PASSIVE} =
4012         exists $CPAN::Config->{ftp_passive} ?
4013         $CPAN::Config->{ftp_passive} : 1;
4014     my $ret;
4015     my $stats = $self->_new_stats($file);
4016   LEVEL: for $levelno (0..$#levels) {
4017         my $level_tuple = $levels[$levelno];
4018         my($level,$scheme,$sitetag) = @$level_tuple;
4019         my $defaultsites = $sitetag && $sitetag eq "defaultsites";
4020         my @urllist;
4021         if ($defaultsites) {
4022             unless (defined $connect_to_internet_ok) {
4023                 $CPAN::Frontend->myprint(sprintf qq{
4024 I would like to connect to one of the following sites to get '%s':
4025
4026 %s
4027 },
4028                                          $file,
4029                                          join("",map { " ".$_->text."\n" } @CPAN::Defaultsites),
4030                                         );
4031                 my $answer = CPAN::Shell::colorable_makemaker_prompt("Is it OK to try to connect to the Internet?", "yes");
4032                 if ($answer =~ /^y/i) {
4033                     $connect_to_internet_ok = 1;
4034                 } else {
4035                     $connect_to_internet_ok = 0;
4036                 }
4037             }
4038             if ($connect_to_internet_ok) {
4039                 @urllist = @CPAN::Defaultsites;
4040             } else {
4041                 @urllist = ();
4042             }
4043         } else {
4044             my @host_seq = $level =~ /dleasy/ ?
4045                 @reordered : 0..$last;  # reordered has file and $Thesiteurl first
4046             @urllist = map { $ccurllist->[$_] } @host_seq;
4047         }
4048         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
4049         my $aslocal_tempfile = $aslocal . ".tmp" . $$;
4050         if (my $recommend = $self->_recommend_url_for($file)) {
4051             @urllist = grep { $_ ne $recommend } @urllist;
4052             unshift @urllist, $recommend;
4053         }
4054         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
4055         $ret = $self->hostdlxxx($level,$scheme,\@urllist,$file,$aslocal_tempfile,$stats);
4056         if ($ret) {
4057             CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG;
4058             if ($ret eq $aslocal_tempfile) {
4059                 # if we got it exactly as we asked for, only then we
4060                 # want to rename
4061                 rename $aslocal_tempfile, $aslocal
4062                     or $CPAN::Frontend->mydie("Error while trying to rename ".
4063                                               "'$ret' to '$aslocal': $!");
4064                 $ret = $aslocal;
4065             }
4066             $Themethod = $level;
4067             my $now = time;
4068             # utime $now, $now, $aslocal; # too bad, if we do that, we
4069                                           # might alter a local mirror
4070             $self->debug("level[$level]") if $CPAN::DEBUG;
4071             last LEVEL;
4072         } else {
4073             unlink $aslocal_tempfile;
4074             last if $CPAN::Signal; # need to cleanup
4075         }
4076     }
4077     if ($ret) {
4078         $stats->{filesize} = -s $ret;
4079     }
4080     $self->debug("before _add_to_statistics") if $CPAN::DEBUG;
4081     $self->_add_to_statistics($stats);
4082     $self->debug("after _add_to_statistics") if $CPAN::DEBUG;
4083     if ($ret) {
4084         unlink "$aslocal.bak$$";
4085         return $ret;
4086     }
4087     unless ($CPAN::Signal) {
4088         my(@mess);
4089         local $" = " ";
4090         if (@{$CPAN::Config->{urllist}}) {
4091             push @mess,
4092                 qq{Please check, if the URLs I found in your configuration file \(}.
4093                     join(", ", @{$CPAN::Config->{urllist}}).
4094                         qq{\) are valid.};
4095         } else {
4096             push @mess, qq{Your urllist is empty!};
4097         }
4098         push @mess, qq{The urllist can be edited.},
4099             qq{E.g. with 'o conf urllist push ftp://myurl/'};
4100         $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
4101         $CPAN::Frontend->mywarn("Could not fetch $file\n");
4102         $CPAN::Frontend->mysleep(2);
4103     }
4104     if ($maybe_restore) {
4105         rename "$aslocal.bak$$", $aslocal;
4106         $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
4107                                  $self->ls($aslocal));
4108         return $aslocal;
4109     }
4110     return;
4111 }
4112
4113 sub mymkpath {
4114     my($self, $aslocal_dir) = @_;
4115     File::Path::mkpath($aslocal_dir);
4116     $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
4117                             qq{directory "$aslocal_dir".
4118     I\'ll continue, but if you encounter problems, they may be due
4119     to insufficient permissions.\n}) unless -w $aslocal_dir;
4120 }
4121
4122 sub hostdlxxx {
4123     my $self = shift;
4124     my $level = shift;
4125     my $scheme = shift;
4126     my $h = shift;
4127     $h = [ grep /^\Q$scheme\E:/, @$h ] if $scheme;
4128     my $method = "host$level";
4129     $self->$method($h, @_);
4130 }
4131
4132 sub _set_attempt {
4133     my($self,$stats,$method,$url) = @_;
4134     push @{$stats->{attempts}}, {
4135                                  method => $method,
4136                                  start => _mytime,
4137                                  url => $url,
4138                                 };
4139 }
4140
4141 # package CPAN::FTP;
4142 sub hostdleasy {
4143     my($self,$host_seq,$file,$aslocal,$stats) = @_;
4144     my($ro_url);
4145   HOSTEASY: for $ro_url (@$host_seq) {
4146         $self->_set_attempt($stats,"dleasy",$ro_url);
4147         my $url .= "$ro_url$file";
4148         $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
4149         if ($url =~ /^file:/) {
4150             my $l;
4151             if ($CPAN::META->has_inst('URI::URL')) {
4152                 my $u =  URI::URL->new($url);
4153                 $l = $u->path;
4154             } else { # works only on Unix, is poorly constructed, but
4155                 # hopefully better than nothing.
4156                 # RFC 1738 says fileurl BNF is
4157                 # fileurl = "file://" [ host | "localhost" ] "/" fpath
4158                 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
4159                 # the code
4160                 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
4161                 $l =~ s|^file:||;                   # assume they
4162                                                     # meant
4163                                                     # file://localhost
4164                 $l =~ s|^/||s
4165                     if ! -f $l && $l =~ m|^/\w:|;   # e.g. /P:
4166             }
4167             $self->debug("local file[$l]") if $CPAN::DEBUG;
4168             if ( -f $l && -r _) {
4169                 $ThesiteURL = $ro_url;
4170                 return $l;
4171             }
4172             if ($l =~ /(.+)\.gz$/) {
4173                 my $ungz = $1;
4174                 if ( -f $ungz && -r _) {
4175                     $ThesiteURL = $ro_url;
4176                     return $ungz;
4177                 }
4178             }
4179             # Maybe mirror has compressed it?
4180             if (-f "$l.gz") {
4181                 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
4182                 eval { CPAN::Tarzip->new("$l.gz")->gunzip($aslocal) };
4183                 if ( -f $aslocal) {
4184                     $ThesiteURL = $ro_url;
4185                     return $aslocal;
4186                 }
4187             }
4188             $CPAN::Frontend->mywarn("Could not find '$l'\n");
4189         }
4190         $self->debug("it was not a file URL") if $CPAN::DEBUG;
4191         if ($CPAN::META->has_usable('LWP')) {
4192             $CPAN::Frontend->myprint("Fetching with LWP:
4193   $url
4194 ");
4195             unless ($Ua) {
4196                 CPAN::LWP::UserAgent->config;
4197                 eval { $Ua = CPAN::LWP::UserAgent->new; };
4198                 if ($@) {
4199                     $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
4200                 }
4201             }
4202             my $res = $Ua->mirror($url, $aslocal);
4203             if ($res->is_success) {
4204                 $ThesiteURL = $ro_url;
4205                 my $now = time;
4206                 utime $now, $now, $aslocal; # download time is more
4207                                             # important than upload
4208                                             # time
4209                 return $aslocal;
4210             } elsif ($url !~ /\.gz(?!\n)\Z/) {
4211                 my $gzurl = "$url.gz";
4212                 $CPAN::Frontend->myprint("Fetching with LWP:
4213   $gzurl
4214 ");
4215                 $res = $Ua->mirror($gzurl, "$aslocal.gz");
4216                 if ($res->is_success) {
4217                     if (eval {CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)}) {
4218                         $ThesiteURL = $ro_url;
4219                         return $aslocal;
4220                     }
4221                 }
4222             } else {
4223                 $CPAN::Frontend->myprint(sprintf(
4224                                                  "LWP failed with code[%s] message[%s]\n",
4225                                                  $res->code,
4226                                                  $res->message,
4227                                                 ));
4228                 # Alan Burlison informed me that in firewall environments
4229                 # Net::FTP can still succeed where LWP fails. So we do not
4230                 # skip Net::FTP anymore when LWP is available.
4231             }
4232         } else {
4233             $CPAN::Frontend->mywarn("  LWP not available\n");
4234         }
4235         return if $CPAN::Signal;
4236         if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
4237             # that's the nice and easy way thanks to Graham
4238             $self->debug("recognized ftp") if $CPAN::DEBUG;
4239             my($host,$dir,$getfile) = ($1,$2,$3);
4240             if ($CPAN::META->has_usable('Net::FTP')) {
4241                 $dir =~ s|/+|/|g;
4242                 $CPAN::Frontend->myprint("Fetching with Net::FTP:
4243   $url
4244 ");
4245                 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
4246                              "aslocal[$aslocal]") if $CPAN::DEBUG;
4247                 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
4248                     $ThesiteURL = $ro_url;
4249                     return $aslocal;
4250                 }
4251                 if ($aslocal !~ /\.gz(?!\n)\Z/) {
4252                     my $gz = "$aslocal.gz";
4253                     $CPAN::Frontend->myprint("Fetching with Net::FTP
4254   $url.gz
4255 ");
4256                     if (CPAN::FTP->ftp_get($host,
4257                                            $dir,
4258                                            "$getfile.gz",
4259                                            $gz) &&
4260                         eval{CPAN::Tarzip->new($gz)->gunzip($aslocal)}
4261                     ) {
4262                         $ThesiteURL = $ro_url;
4263                         return $aslocal;
4264                     }
4265                 }
4266                 # next HOSTEASY;
4267             } else {
4268                 CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG;
4269             }
4270         }
4271         if (
4272             UNIVERSAL::can($ro_url,"text")
4273             and
4274             $ro_url->{FROM} eq "USER"
4275            ) {
4276             ##address #17973: default URLs should not try to override
4277             ##user-defined URLs just because LWP is not available
4278             my $ret = $self->hostdlhard([$ro_url],$file,$aslocal,$stats);
4279             return $ret if $ret;
4280         }
4281         return if $CPAN::Signal;
4282     }
4283 }
4284
4285 # package CPAN::FTP;
4286 sub hostdlhard {
4287     my($self,$host_seq,$file,$aslocal,$stats) = @_;
4288
4289     # Came back if Net::FTP couldn't establish connection (or
4290     # failed otherwise) Maybe they are behind a firewall, but they
4291     # gave us a socksified (or other) ftp program...
4292
4293     my($ro_url);
4294     my($devnull) = $CPAN::Config->{devnull} || "";
4295     # < /dev/null ";
4296     my($aslocal_dir) = File::Basename::dirname($aslocal);
4297     File::Path::mkpath($aslocal_dir);
4298   HOSTHARD: for $ro_url (@$host_seq) {
4299         $self->_set_attempt($stats,"dlhard",$ro_url);
4300         my $url = "$ro_url$file";
4301         my($proto,$host,$dir,$getfile);
4302
4303         # Courtesy Mark Conty mark_conty@cargill.com change from
4304         # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
4305         # to
4306         if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
4307             # proto not yet used
4308             ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
4309         } else {
4310             next HOSTHARD; # who said, we could ftp anything except ftp?
4311         }
4312         next HOSTHARD if $proto eq "file"; # file URLs would have had
4313                                            # success above. Likely a bogus URL
4314
4315         $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
4316
4317         # Try the most capable first and leave ncftp* for last as it only
4318         # does FTP.
4319       DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
4320             my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
4321             next unless defined $funkyftp;
4322             next if $funkyftp =~ /^\s*$/;
4323
4324             my($asl_ungz, $asl_gz);
4325             ($asl_ungz = $aslocal) =~ s/\.gz//;
4326                 $asl_gz = "$asl_ungz.gz";
4327
4328             my($src_switch) = "";
4329             my($chdir) = "";
4330             my($stdout_redir) = " > $asl_ungz";
4331             if ($f eq "lynx") {
4332                 $src_switch = " -source";
4333             } elsif ($f eq "ncftp") {
4334                 $src_switch = " -c";
4335             } elsif ($f eq "wget") {
4336                 $src_switch = " -O $asl_ungz";
4337                 $stdout_redir = "";
4338             } elsif ($f eq 'curl') {
4339                 $src_switch = ' -L -f -s -S --netrc-optional';
4340             }
4341
4342             if ($f eq "ncftpget") {
4343                 $chdir = "cd $aslocal_dir && ";
4344                 $stdout_redir = "";
4345             }
4346             $CPAN::Frontend->myprint(
4347                                      qq[
4348 Trying with "$funkyftp$src_switch" to get
4349     $url
4350 ]);
4351             my($system) =
4352                 "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
4353             $self->debug("system[$system]") if $CPAN::DEBUG;
4354             my($wstatus) = system($system);
4355             if ($f eq "lynx") {
4356                 # lynx returns 0 when it fails somewhere
4357                 if (-s $asl_ungz) {
4358                     my $content = do { local *FH;
4359                                        open FH, $asl_ungz or die;
4360                                        local $/;
4361                                        <FH> };
4362                     if ($content =~ /^<.*(<title>[45]|Error [45])/si) {
4363                         $CPAN::Frontend->mywarn(qq{
4364 No success, the file that lynx has downloaded looks like an error message:
4365 $content
4366 });
4367                         $CPAN::Frontend->mysleep(1);
4368                         next DLPRG;
4369                     }
4370                 } else {
4371                     $CPAN::Frontend->myprint(qq{
4372 No success, the file that lynx has downloaded is an empty file.
4373 });
4374                     next DLPRG;
4375                 }
4376             }
4377             if ($wstatus == 0) {
4378                 if (-s $aslocal) {
4379                     # Looks good
4380                 } elsif ($asl_ungz ne $aslocal) {
4381                     # test gzip integrity
4382                     if (eval{CPAN::Tarzip->new($asl_ungz)->gtest}) {
4383                         # e.g. foo.tar is gzipped --> foo.tar.gz
4384                         rename $asl_ungz, $aslocal;
4385                     } else {
4386                         eval{CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz)};
4387                     }
4388                 }
4389                 $ThesiteURL = $ro_url;
4390                 return $aslocal;
4391             } elsif ($url !~ /\.gz(?!\n)\Z/) {
4392                 unlink $asl_ungz if
4393                     -f $asl_ungz && -s _ == 0;
4394                 my $gz = "$aslocal.gz";
4395                 my $gzurl = "$url.gz";
4396                 $CPAN::Frontend->myprint(
4397                                         qq[
4398     Trying with "$funkyftp$src_switch" to get
4399     $url.gz
4400     ]);
4401                 my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
4402                 $self->debug("system[$system]") if $CPAN::DEBUG;
4403                 my($wstatus);
4404                 if (($wstatus = system($system)) == 0
4405                     &&
4406                     -s $asl_gz
4407                 ) {
4408                     # test gzip integrity
4409                     my $ct = eval{CPAN::Tarzip->new($asl_gz)};
4410                     if ($ct && $ct->gtest) {
4411                         $ct->gunzip($aslocal);
4412                     } else {
4413                         # somebody uncompressed file for us?
4414                         rename $asl_ungz, $aslocal;
4415                     }
4416                     $ThesiteURL = $ro_url;
4417                     return $aslocal;
4418                 } else {
4419                     unlink $asl_gz if -f $asl_gz;
4420                 }
4421             } else {
4422                 my $estatus = $wstatus >> 8;
4423                 my $size = -f $aslocal ?
4424                     ", left\n$aslocal with size ".-s _ :
4425                     "\nWarning: expected file [$aslocal] doesn't exist";
4426                 $CPAN::Frontend->myprint(qq{
4427     System call "$system"
4428     returned status $estatus (wstat $wstatus)$size
4429     });
4430             }
4431             return if $CPAN::Signal;
4432         } # transfer programs
4433     } # host
4434 }
4435
4436 # package CPAN::FTP;
4437 sub hostdlhardest {
4438     my($self,$host_seq,$file,$aslocal,$stats) = @_;
4439
4440     return unless @$host_seq;
4441     my($ro_url);
4442     my($aslocal_dir) = File::Basename::dirname($aslocal);
4443     File::Path::mkpath($aslocal_dir);
4444     my $ftpbin = $CPAN::Config->{ftp};
4445     unless ($ftpbin && length $ftpbin && MM->maybe_command($ftpbin)) {
4446         $CPAN::Frontend->myprint("No external ftp command available\n\n");
4447         return;
4448     }
4449     $CPAN::Frontend->mywarn(qq{
4450 As a last ressort we now switch to the external ftp command '$ftpbin'
4451 to get '$aslocal'.
4452
4453 Doing so often leads to problems that are hard to diagnose.
4454
4455 If you're victim of such problems, please consider unsetting the ftp
4456 config variable with
4457
4458     o conf ftp ""
4459     o conf commit
4460
4461 });
4462     $CPAN::Frontend->mysleep(2);
4463   HOSTHARDEST: for $ro_url (@$host_seq) {
4464         $self->_set_attempt($stats,"dlhardest",$ro_url);
4465         my $url = "$ro_url$file";
4466         $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
4467         unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
4468             next;
4469         }
4470         my($host,$dir,$getfile) = ($1,$2,$3);
4471         my $timestamp = 0;
4472         my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
4473             $ctime,$blksize,$blocks) = stat($aslocal);
4474         $timestamp = $mtime ||= 0;
4475         my($netrc) = CPAN::FTP::netrc->new;
4476         my($netrcfile) = $netrc->netrc;
4477         my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
4478         my $targetfile = File::Basename::basename($aslocal);
4479         my(@dialog);
4480         push(
4481              @dialog,
4482              "lcd $aslocal_dir",
4483              "cd /",
4484              map("cd $_", split /\//, $dir), # RFC 1738
4485              "bin",
4486              "get $getfile $targetfile",
4487              "quit"
4488         );
4489         if (! $netrcfile) {
4490             CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
4491         } elsif ($netrc->hasdefault || $netrc->contains($host)) {
4492             CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
4493                                 $netrc->hasdefault,
4494                                 $netrc->contains($host))) if $CPAN::DEBUG;
4495             if ($netrc->protected) {
4496                 my $dialog = join "", map { "    $_\n" } @dialog;
4497                 my $netrc_explain;
4498                 if ($netrc->contains($host)) {
4499                     $netrc_explain = "Relying that your .netrc entry for '$host' ".
4500                         "manages the login";
4501                 } else {
4502                     $netrc_explain = "Relying that your default .netrc entry ".
4503                         "manages the login";
4504                 }
4505                 $CPAN::Frontend->myprint(qq{
4506   Trying with external ftp to get
4507     $url
4508   $netrc_explain
4509   Going to send the dialog
4510 $dialog
4511 }
4512                 );
4513                 $self->talk_ftp("$ftpbin$verbose $host",
4514                                 @dialog);
4515                 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4516                     $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
4517                 $mtime ||= 0;
4518                 if ($mtime > $timestamp) {
4519                     $CPAN::Frontend->myprint("GOT $aslocal\n");
4520                     $ThesiteURL = $ro_url;
4521                     return $aslocal;
4522                 } else {
4523                     $CPAN::Frontend->myprint("Hmm... Still failed!\n");
4524                 }
4525                     return if $CPAN::Signal;
4526             } else {
4527                 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
4528                                         qq{correctly protected.\n});
4529             }
4530         } else {
4531             $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
4532   nor does it have a default entry\n");
4533         }
4534
4535         # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
4536         # then and login manually to host, using e-mail as
4537         # password.
4538         $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
4539         unshift(
4540                 @dialog,
4541                 "open $host",
4542                 "user anonymous $Config::Config{'cf_email'}"
4543         );
4544         my $dialog = join "", map { "    $_\n" } @dialog;
4545         $CPAN::Frontend->myprint(qq{
4546   Trying with external ftp to get
4547     $url
4548   Going to send the dialog
4549 $dialog
4550 }
4551         );
4552         $self->talk_ftp("$ftpbin$verbose -n", @dialog);
4553         ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4554             $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
4555         $mtime ||= 0;
4556         if ($mtime > $timestamp) {
4557             $CPAN::Frontend->myprint("GOT $aslocal\n");
4558             $ThesiteURL = $ro_url;
4559             return $aslocal;
4560         } else {
4561             $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
4562         }
4563         return if $CPAN::Signal;
4564         $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
4565         $CPAN::Frontend->mysleep(2);
4566     } # host
4567 }
4568
4569 # package CPAN::FTP;
4570 sub talk_ftp {
4571     my($self,$command,@dialog) = @_;
4572     my $fh = FileHandle->new;
4573     $fh->open("|$command") or die "Couldn't open ftp: $!";
4574     foreach (@dialog) { $fh->print("$_\n") }
4575     $fh->close; # Wait for process to complete
4576     my $wstatus = $?;
4577     my $estatus = $wstatus >> 8;
4578     $CPAN::Frontend->myprint(qq{
4579 Subprocess "|$command"
4580   returned status $estatus (wstat $wstatus)
4581 }) if $wstatus;
4582 }
4583
4584 # find2perl needs modularization, too, all the following is stolen
4585 # from there
4586 # CPAN::FTP::ls
4587 sub ls {
4588     my($self,$name) = @_;
4589     my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
4590      $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
4591
4592     my($perms,%user,%group);
4593     my $pname = $name;
4594
4595     if ($blocks) {
4596         $blocks = int(($blocks + 1) / 2);
4597     }
4598     else {
4599         $blocks = int(($sizemm + 1023) / 1024);
4600     }
4601
4602     if    (-f _) { $perms = '-'; }
4603     elsif (-d _) { $perms = 'd'; }
4604     elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
4605     elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
4606     elsif (-p _) { $perms = 'p'; }
4607     elsif (-S _) { $perms = 's'; }
4608     else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
4609
4610     my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
4611     my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
4612     my $tmpmode = $mode;
4613     my $tmp = $rwx[$tmpmode & 7];
4614     $tmpmode >>= 3;
4615     $tmp = $rwx[$tmpmode & 7] . $tmp;
4616     $tmpmode >>= 3;
4617     $tmp = $rwx[$tmpmode & 7] . $tmp;
4618     substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
4619     substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
4620     substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
4621     $perms .= $tmp;
4622
4623     my $user = $user{$uid} || $uid;   # too lazy to implement lookup
4624     my $group = $group{$gid} || $gid;
4625
4626     my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
4627     my($timeyear);
4628     my($moname) = $moname[$mon];
4629     if (-M _ > 365.25 / 2) {
4630         $timeyear = $year + 1900;
4631     }
4632     else {
4633         $timeyear = sprintf("%02d:%02d", $hour, $min);
4634     }
4635
4636     sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
4637              $ino,
4638                   $blocks,
4639                        $perms,
4640                              $nlink,
4641                                  $user,
4642                                       $group,
4643                                            $sizemm,
4644                                                $moname,
4645                                                   $mday,
4646                                                       $timeyear,
4647                                                           $pname;
4648 }
4649
4650 package CPAN::FTP::netrc;
4651 use strict;
4652
4653 # package CPAN::FTP::netrc;
4654 sub new {
4655     my($class) = @_;
4656     my $home = CPAN::HandleConfig::home;
4657     my $file = File::Spec->catfile($home,".netrc");
4658
4659     my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4660        $atime,$mtime,$ctime,$blksize,$blocks)
4661         = stat($file);
4662     $mode ||= 0;
4663     my $protected = 0;
4664
4665     my($fh,@machines,$hasdefault);
4666     $hasdefault = 0;
4667     $fh = FileHandle->new or die "Could not create a filehandle";
4668
4669     if($fh->open($file)) {
4670         $protected = ($mode & 077) == 0;
4671         local($/) = "";
4672       NETRC: while (<$fh>) {
4673             my(@tokens) = split " ", $_;
4674           TOKEN: while (@tokens) {
4675                 my($t) = shift @tokens;
4676                 if ($t eq "default") {
4677                     $hasdefault++;
4678                     last NETRC;
4679                 }
4680                 last TOKEN if $t eq "macdef";
4681                 if ($t eq "machine") {
4682                     push @machines, shift @tokens;
4683                 }
4684             }
4685         }
4686     } else {
4687         $file = $hasdefault = $protected = "";
4688     }
4689
4690     bless {
4691         'mach' => [@machines],
4692         'netrc' => $file,
4693         'hasdefault' => $hasdefault,
4694         'protected' => $protected,
4695     }, $class;
4696 }
4697
4698 # CPAN::FTP::netrc::hasdefault;
4699 sub hasdefault { shift->{'hasdefault'} }
4700 sub netrc      { shift->{'netrc'}      }
4701 sub protected  { shift->{'protected'}  }
4702 sub contains {
4703     my($self,$mach) = @_;
4704     for ( @{$self->{'mach'}} ) {
4705         return 1 if $_ eq $mach;
4706     }
4707     return 0;
4708 }
4709
4710 package CPAN::Complete;
4711 use strict;
4712
4713 sub gnu_cpl {
4714     my($text, $line, $start, $end) = @_;
4715     my(@perlret) = cpl($text, $line, $start);
4716     # find longest common match. Can anybody show me how to peruse
4717     # T::R::Gnu to have this done automatically? Seems expensive.
4718     return () unless @perlret;
4719     my($newtext) = $text;
4720     for (my $i = length($text)+1;;$i++) {
4721         last unless length($perlret[0]) && length($perlret[0]) >= $i;
4722         my $try = substr($perlret[0],0,$i);
4723         my @tries = grep {substr($_,0,$i) eq $try} @perlret;
4724         # warn "try[$try]tries[@tries]";
4725         if (@tries == @perlret) {
4726             $newtext = $try;
4727         } else {
4728             last;
4729         }
4730     }
4731     ($newtext,@perlret);
4732 }
4733
4734 #-> sub CPAN::Complete::cpl ;
4735 sub cpl {
4736     my($word,$line,$pos) = @_;
4737     $word ||= "";
4738     $line ||= "";
4739     $pos ||= 0;
4740     CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4741     $line =~ s/^\s*//;
4742     if ($line =~ s/^((?:notest|f?force)\s*)//) {
4743         $pos -= length($1);
4744     }
4745     my @return;
4746     if ($pos == 0 || $line =~ /^(?:h(?:elp)?|\?)\s/) {
4747         @return = grep /^\Q$word\E/, @CPAN::Complete::COMMANDS;
4748     } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
4749         @return = ();
4750     } elsif ($line =~ /^(a|ls)\s/) {
4751         @return = cplx('CPAN::Author',uc($word));
4752     } elsif ($line =~ /^b\s/) {
4753         CPAN::Shell->local_bundles;
4754         @return = cplx('CPAN::Bundle',$word);
4755     } elsif ($line =~ /^d\s/) {
4756         @return = cplx('CPAN::Distribution',$word);
4757     } elsif ($line =~ m/^(
4758                           [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
4759                          )\s/x ) {
4760         if ($word =~ /^Bundle::/) {
4761             CPAN::Shell->local_bundles;
4762         }
4763         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
4764     } elsif ($line =~ /^i\s/) {
4765         @return = cpl_any($word);
4766     } elsif ($line =~ /^reload\s/) {
4767         @return = cpl_reload($word,$line,$pos);
4768     } elsif ($line =~ /^o\s/) {
4769         @return = cpl_option($word,$line,$pos);
4770     } elsif ($line =~ m/^\S+\s/ ) {
4771         # fallback for future commands and what we have forgotten above
4772         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
4773     } else {
4774         @return = ();
4775     }
4776     return @return;
4777 }
4778
4779 #-> sub CPAN::Complete::cplx ;
4780 sub cplx {
4781     my($class, $word) = @_;
4782     if (CPAN::_sqlite_running) {
4783         $CPAN::SQLite->search($class, "^\Q$word\E");
4784     }
4785     sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
4786 }
4787
4788 #-> sub CPAN::Complete::cpl_any ;
4789 sub cpl_any {
4790     my($word) = shift;
4791     return (
4792             cplx('CPAN::Author',$word),
4793             cplx('CPAN::Bundle',$word),
4794             cplx('CPAN::Distribution',$word),
4795             cplx('CPAN::Module',$word),
4796            );
4797 }
4798
4799 #-> sub CPAN::Complete::cpl_reload ;
4800 sub cpl_reload {
4801     my($word,$line,$pos) = @_;
4802     $word ||= "";
4803     my(@words) = split " ", $line;
4804     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4805     my(@ok) = qw(cpan index);
4806     return @ok if @words == 1;
4807     return grep /^\Q$word\E/, @ok if @words == 2 && $word;
4808 }
4809
4810 #-> sub CPAN::Complete::cpl_option ;
4811 sub cpl_option {
4812     my($word,$line,$pos) = @_;
4813     $word ||= "";
4814     my(@words) = split " ", $line;
4815     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4816     my(@ok) = qw(conf debug);
4817     return @ok if @words == 1;
4818     return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
4819     if (0) {
4820     } elsif ($words[1] eq 'index') {
4821         return ();
4822     } elsif ($words[1] eq 'conf') {
4823         return CPAN::HandleConfig::cpl(@_);
4824     } elsif ($words[1] eq 'debug') {
4825         return sort grep /^\Q$word\E/i,
4826             sort keys %CPAN::DEBUG, 'all';
4827     }
4828 }
4829
4830 package CPAN::Index;
4831 use strict;
4832
4833 #-> sub CPAN::Index::force_reload ;
4834 sub force_reload {
4835     my($class) = @_;
4836     $CPAN::Index::LAST_TIME = 0;
4837     $class->reload(1);
4838 }
4839
4840 #-> sub CPAN::Index::reload ;
4841 sub reload {
4842     my($self,$force) = @_;
4843     my $time = time;
4844
4845     # XXX check if a newer one is available. (We currently read it
4846     # from time to time)
4847     for ($CPAN::Config->{index_expire}) {
4848         $_ = 0.001 unless $_ && $_ > 0.001;
4849     }
4850     unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
4851         # debug here when CPAN doesn't seem to read the Metadata
4852         require Carp;
4853         Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
4854     }
4855     unless ($CPAN::META->{PROTOCOL}) {
4856         $self->read_metadata_cache;
4857         $CPAN::META->{PROTOCOL} ||= "1.0";
4858     }
4859     if ( $CPAN::META->{PROTOCOL} < PROTOCOL  ) {
4860         # warn "Setting last_time to 0";
4861         $LAST_TIME = 0; # No warning necessary
4862     }
4863     if ($LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
4864         and ! $force) {
4865         # called too often
4866         # CPAN->debug("LAST_TIME[$LAST_TIME]index_expire[$CPAN::Config->{index_expire}]time[$time]");
4867     } elsif (0) {
4868         # IFF we are developing, it helps to wipe out the memory
4869         # between reloads, otherwise it is not what a user expects.
4870         undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
4871         $CPAN::META = CPAN->new;
4872     } else {
4873         my($debug,$t2);
4874         local $LAST_TIME = $time;
4875         local $CPAN::META->{PROTOCOL} = PROTOCOL;
4876
4877         my $needshort = $^O eq "dos";
4878
4879         $self->rd_authindex($self
4880                           ->reload_x(
4881                                      "authors/01mailrc.txt.gz",
4882                                      $needshort ?
4883                                      File::Spec->catfile('authors', '01mailrc.gz') :
4884                                      File::Spec->catfile('authors', '01mailrc.txt.gz'),
4885                                      $force));
4886         $t2 = time;
4887         $debug = "timing reading 01[".($t2 - $time)."]";
4888         $time = $t2;
4889         return if $CPAN::Signal; # this is sometimes lengthy
4890         $self->rd_modpacks($self
4891                          ->reload_x(
4892                                     "modules/02packages.details.txt.gz",
4893                                     $needshort ?
4894                                     File::Spec->catfile('modules', '02packag.gz') :
4895                                     File::Spec->catfile('modules', '02packages.details.txt.gz'),
4896                                     $force));
4897         $t2 = time;
4898         $debug .= "02[".($t2 - $time)."]";
4899         $time = $t2;
4900         return if $CPAN::Signal; # this is sometimes lengthy
4901         $self->rd_modlist($self
4902                         ->reload_x(
4903                                    "modules/03modlist.data.gz",
4904                                    $needshort ?
4905                                    File::Spec->catfile('modules', '03mlist.gz') :
4906                                    File::Spec->catfile('modules', '03modlist.data.gz'),
4907                                    $force));
4908         $self->write_metadata_cache;
4909         $t2 = time;
4910         $debug .= "03[".($t2 - $time)."]";
4911         $time = $t2;
4912         CPAN->debug($debug) if $CPAN::DEBUG;
4913     }
4914     if ($CPAN::Config->{build_dir_reuse}) {
4915         $self->reanimate_build_dir;
4916     }
4917     if (CPAN::_sqlite_running) {
4918         $CPAN::SQLite->reload(time => $time, force => $force)
4919             if not $LAST_TIME;
4920     }
4921     $LAST_TIME = $time;
4922     $CPAN::META->{PROTOCOL} = PROTOCOL;
4923 }
4924
4925 #-> sub CPAN::Index::reanimate_build_dir ;
4926 sub reanimate_build_dir {
4927     my($self) = @_;
4928     unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module}||"YAML")) {
4929         return;
4930     }
4931     return if $HAVE_REANIMATED++;
4932     my $d = $CPAN::Config->{build_dir};
4933     my $dh = DirHandle->new;
4934     opendir $dh, $d or return; # does not exist
4935     my $dirent;
4936     my $i = 0;
4937     my $painted = 0;
4938     my $restored = 0;
4939     $CPAN::Frontend->myprint("Going to read $CPAN::Config->{build_dir}/\n");
4940     my @candidates = map { $_->[0] }
4941         sort { $b->[1] <=> $a->[1] }
4942             map { [ $_, -M File::Spec->catfile($d,$_) ] }
4943                 grep {/\.yml$/} readdir $dh;
4944   DISTRO: for $i (0..$#candidates) {
4945         my $dirent = $candidates[$i];
4946         my $y = eval {CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))};
4947         if ($@) {
4948             warn "Error while parsing file '$dirent'; error: '$@'";
4949             next DISTRO;
4950         }
4951         my $c = $y->[0];
4952         if ($c && CPAN->_perl_fingerprint($c->{perl})) {
4953             my $key = $c->{distribution}{ID};
4954             for my $k (keys %{$c->{distribution}}) {
4955                 if ($c->{distribution}{$k}
4956                     && ref $c->{distribution}{$k}
4957                     && UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) {
4958                     $c->{distribution}{$k}{COMMANDID} = $i - @candidates;
4959                 }
4960             }
4961
4962             #we tried to restore only if element already
4963             #exists; but then we do not work with metadata
4964             #turned off.
4965             my $do
4966                 = $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key}
4967                     = $c->{distribution};
4968             for my $skipper (qw(
4969                                 badtestcnt
4970                                 configure_requires_later
4971                                 configure_requires_later_for
4972                                 force_update
4973                                 later
4974                                 later_for
4975                                 notest
4976                                 should_report
4977                                 sponsored_mods
4978                                )) {
4979                 delete $do->{$skipper};
4980             }
4981             # $DB::single = 1;
4982             if ($do->{make_test}
4983                 && $do->{build_dir}
4984                 && !(UNIVERSAL::can($do->{make_test},"failed") ?
4985                      $do->{make_test}->failed :
4986                      $do->{make_test} =~ /^YES/
4987                     )
4988                 && (
4989                     !$do->{install}
4990                     ||
4991                     $do->{install}->failed
4992                    )
4993                ) {
4994                 $CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME});
4995             }
4996             $restored++;
4997         }
4998         $i++;
4999         while (($painted/76) < ($i/@candidates)) {
5000             $CPAN::Frontend->myprint(".");
5001             $painted++;
5002         }
5003     }
5004     $CPAN::Frontend->myprint(sprintf(
5005                                      "DONE\nFound %s old build%s, restored the state of %s\n",
5006                                      @candidates ? sprintf("%d",scalar @candidates) : "no",
5007                                      @candidates==1 ? "" : "s",
5008                                      $restored || "none",
5009                                     ));
5010 }
5011
5012
5013 #-> sub CPAN::Index::reload_x ;
5014 sub reload_x {
5015     my($cl,$wanted,$localname,$force) = @_;
5016     $force |= 2; # means we're dealing with an index here
5017     CPAN::HandleConfig->load; # we should guarantee loading wherever
5018                               # we rely on Config XXX
5019     $localname ||= $wanted;
5020     my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
5021                                          $localname);
5022     if (
5023         -f $abs_wanted &&
5024         -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
5025         !($force & 1)
5026        ) {
5027         my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
5028         $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
5029                    qq{day$s. I\'ll use that.});
5030         return $abs_wanted;
5031     } else {
5032         $force |= 1; # means we're quite serious about it.
5033     }
5034     return CPAN::FTP->localize($wanted,$abs_wanted,$force);
5035 }
5036
5037 #-> sub CPAN::Index::rd_authindex ;
5038 sub rd_authindex {
5039     my($cl, $index_target) = @_;
5040     return unless defined $index_target;
5041     return if CPAN::_sqlite_running;
5042     my @lines;
5043     $CPAN::Frontend->myprint("Going to read $index_target\n");
5044     local(*FH);
5045     tie *FH, 'CPAN::Tarzip', $index_target;
5046     local($/) = "\n";
5047     local($_);
5048     push @lines, split /\012/ while <FH>;
5049     my $i = 0;
5050     my $painted = 0;
5051     foreach (@lines) {
5052         my($userid,$fullname,$email) =
5053             m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/;
5054         $fullname ||= $email;
5055         if ($userid && $fullname && $email) {
5056             my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
5057             $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
5058         } else {
5059             CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG;
5060         }
5061         $i++;
5062         while (($painted/76) < ($i/@lines)) {
5063             $CPAN::Frontend->myprint(".");
5064             $painted++;
5065         }
5066         return if $CPAN::Signal;
5067     }
5068     $CPAN::Frontend->myprint("DONE\n");
5069 }
5070
5071 sub userid {
5072   my($self,$dist) = @_;
5073   $dist = $self->{'id'} unless defined $dist;
5074   my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
5075   $ret;
5076 }
5077
5078 #-> sub CPAN::Index::rd_modpacks ;
5079 sub rd_modpacks {
5080     my($self, $index_target) = @_;
5081     return unless defined $index_target;
5082     return if CPAN::_sqlite_running;
5083     $CPAN::Frontend->myprint("Going to read $index_target\n");
5084     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
5085     local $_;
5086     CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
5087     my $slurp = "";
5088     my $chunk;
5089     while (my $bytes = $fh->READ(\$chunk,8192)) {
5090         $slurp.=$chunk;
5091     }
5092     my @lines = split /\012/, $slurp;
5093     CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
5094     undef $fh;
5095     # read header
5096     my($line_count,$last_updated);
5097     while (@lines) {
5098         my $shift = shift(@lines);
5099         last if $shift =~ /^\s*$/;
5100         $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
5101         $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
5102     }
5103     CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
5104     if (not defined $line_count) {
5105
5106         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
5107 Please check the validity of the index file by comparing it to more
5108 than one CPAN mirror. I'll continue but problems seem likely to
5109 happen.\a
5110 });
5111
5112         $CPAN::Frontend->mysleep(5);
5113     } elsif ($line_count != scalar @lines) {
5114
5115         $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
5116 contains a Line-Count header of %d but I see %d lines there. Please
5117 check the validity of the index file by comparing it to more than one
5118 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
5119 $index_target, $line_count, scalar(@lines));
5120
5121     }
5122     if (not defined $last_updated) {
5123
5124         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
5125 Please check the validity of the index file by comparing it to more
5126 than one CPAN mirror. I'll continue but problems seem likely to
5127 happen.\a
5128 });
5129
5130         $CPAN::Frontend->mysleep(5);
5131     } else {
5132
5133         $CPAN::Frontend
5134             ->myprint(sprintf qq{  Database was generated on %s\n},
5135                       $last_updated);
5136         $DATE_OF_02 = $last_updated;
5137
5138         my $age = time;
5139         if ($CPAN::META->has_inst('HTTP::Date')) {
5140             require HTTP::Date;
5141             $age -= HTTP::Date::str2time($last_updated);
5142         } else {
5143             $CPAN::Frontend->mywarn("  HTTP::Date not available\n");
5144             require Time::Local;
5145             my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
5146             $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
5147             $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
5148         }
5149         $age /= 3600*24;
5150         if ($age > 30) {
5151
5152             $CPAN::Frontend
5153                 ->mywarn(sprintf
5154                          qq{Warning: This index file is %d days old.
5155   Please check the host you chose as your CPAN mirror for staleness.
5156   I'll continue but problems seem likely to happen.\a\n},
5157                          $age);
5158
5159         } elsif ($age < -1) {
5160
5161             $CPAN::Frontend
5162                 ->mywarn(sprintf
5163                          qq{Warning: Your system date is %d days behind this index file!
5164   System time:          %s
5165   Timestamp index file: %s
5166   Please fix your system time, problems with the make command expected.\n},
5167                          -$age,
5168                          scalar gmtime,
5169                          $DATE_OF_02,
5170                         );
5171
5172         }
5173     }
5174
5175
5176     # A necessity since we have metadata_cache: delete what isn't
5177     # there anymore
5178     my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
5179     CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
5180     my(%exists);
5181     my $i = 0;
5182     my $painted = 0;
5183     foreach (@lines) {
5184         # before 1.56 we split into 3 and discarded the rest. From
5185         # 1.57 we assign remaining text to $comment thus allowing to
5186         # influence isa_perl
5187         my($mod,$version,$dist,$comment) = split " ", $_, 4;
5188         my($bundle,$id,$userid);
5189
5190         if ($mod eq 'CPAN' &&
5191             ! (
5192             CPAN::Queue->exists('Bundle::CPAN') ||
5193             CPAN::Queue->exists('CPAN')
5194             )
5195         ) {
5196             local($^W)= 0;
5197             if ($version > $CPAN::VERSION) {
5198                 $CPAN::Frontend->mywarn(qq{
5199   New CPAN.pm version (v$version) available.
5200   [Currently running version is v$CPAN::VERSION]
5201   You might want to try
5202     install CPAN
5203     reload cpan
5204   to both upgrade CPAN.pm and run the new version without leaving
5205   the current session.
5206
5207 }); #});
5208                 $CPAN::Frontend->mysleep(2);
5209                 $CPAN::Frontend->myprint(qq{\n});
5210             }
5211             last if $CPAN::Signal;
5212         } elsif ($mod =~ /^Bundle::(.*)/) {
5213             $bundle = $1;
5214         }
5215
5216         if ($bundle) {
5217             $id =  $CPAN::META->instance('CPAN::Bundle',$mod);
5218             # Let's make it a module too, because bundles have so much
5219             # in common with modules.
5220
5221             # Changed in 1.57_63: seems like memory bloat now without
5222             # any value, so commented out
5223
5224             # $CPAN::META->instance('CPAN::Module',$mod);
5225
5226         } else {
5227
5228             # instantiate a module object
5229             $id = $CPAN::META->instance('CPAN::Module',$mod);
5230
5231         }
5232
5233         # Although CPAN prohibits same name with different version the
5234         # indexer may have changed the version for the same distro
5235         # since the last time ("Force Reindexing" feature)
5236         if ($id->cpan_file ne $dist
5237             ||
5238             $id->cpan_version ne $version
5239            ) {
5240             $userid = $id->userid || $self->userid($dist);
5241             $id->set(
5242                      'CPAN_USERID' => $userid,
5243                      'CPAN_VERSION' => $version,
5244                      'CPAN_FILE' => $dist,
5245                     );
5246         }
5247
5248         # instantiate a distribution object
5249         if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
5250         # we do not need CONTAINSMODS unless we do something with
5251         # this dist, so we better produce it on demand.
5252
5253         ## my $obj = $CPAN::META->instance(
5254         ##                                 'CPAN::Distribution' => $dist
5255         ##                                );
5256         ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
5257         } else {
5258             $CPAN::META->instance(
5259                                   'CPAN::Distribution' => $dist
5260                                  )->set(
5261                                         'CPAN_USERID' => $userid,
5262                                         'CPAN_COMMENT' => $comment,
5263                                        );
5264         }
5265         if ($secondtime) {
5266             for my $name ($mod,$dist) {
5267                 # $self->debug("exists name[$name]") if $CPAN::DEBUG;
5268                 $exists{$name} = undef;
5269             }
5270         }
5271         $i++;
5272         while (($painted/76) < ($i/@lines)) {
5273             $CPAN::Frontend->myprint(".");
5274             $painted++;
5275         }
5276         return if $CPAN::Signal;
5277     }
5278     $CPAN::Frontend->myprint("DONE\n");
5279     if ($secondtime) {
5280         for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
5281             for my $o ($CPAN::META->all_objects($class)) {
5282                 next if exists $exists{$o->{ID}};
5283                 $CPAN::META->delete($class,$o->{ID});
5284                 # CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
5285                 #     if $CPAN::DEBUG;
5286             }
5287         }
5288     }
5289 }
5290
5291 #-> sub CPAN::Index::rd_modlist ;
5292 sub rd_modlist {
5293     my($cl,$index_target) = @_;
5294     return unless defined $index_target;
5295     return if CPAN::_sqlite_running;
5296     $CPAN::Frontend->myprint("Going to read $index_target\n");
5297     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
5298     local $_;
5299     my $slurp = "";
5300     my $chunk;
5301     while (my $bytes = $fh->READ(\$chunk,8192)) {
5302         $slurp.=$chunk;
5303     }
5304     my @eval2 = split /\012/, $slurp;
5305
5306     while (@eval2) {
5307         my $shift = shift(@eval2);
5308         if ($shift =~ /^Date:\s+(.*)/) {
5309             if ($DATE_OF_03 eq $1) {
5310                 $CPAN::Frontend->myprint("Unchanged.\n");
5311                 return;
5312             }
5313             ($DATE_OF_03) = $1;
5314         }
5315         last if $shift =~ /^\s*$/;
5316     }
5317     push @eval2, q{CPAN::Modulelist->data;};
5318     local($^W) = 0;
5319     my($comp) = Safe->new("CPAN::Safe1");
5320     my($eval2) = join("\n", @eval2);
5321     CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG;
5322     my $ret = $comp->reval($eval2);
5323     Carp::confess($@) if $@;
5324     return if $CPAN::Signal;
5325     my $i = 0;
5326     my $until = keys(%$ret);
5327     my $painted = 0;
5328     CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
5329     for (keys %$ret) {
5330         my $obj = $CPAN::META->instance("CPAN::Module",$_);
5331         delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
5332         $obj->set(%{$ret->{$_}});
5333         $i++;
5334         while (($painted/76) < ($i/$until)) {
5335             $CPAN::Frontend->myprint(".");
5336             $painted++;
5337         }
5338         return if $CPAN::Signal;
5339     }
5340     $CPAN::Frontend->myprint("DONE\n");
5341 }
5342
5343 #-> sub CPAN::Index::write_metadata_cache ;
5344 sub write_metadata_cache {
5345     my($self) = @_;
5346     return unless $CPAN::Config->{'cache_metadata'};
5347     return if CPAN::_sqlite_running;
5348     return unless $CPAN::META->has_usable("Storable");
5349     my $cache;
5350     foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
5351                       CPAN::Distribution)) {
5352         $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
5353     }
5354     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
5355     $cache->{last_time} = $LAST_TIME;
5356     $cache->{DATE_OF_02} = $DATE_OF_02;
5357     $cache->{PROTOCOL} = PROTOCOL;
5358     $CPAN::Frontend->myprint("Going to write $metadata_file\n");
5359     eval { Storable::nstore($cache, $metadata_file) };
5360     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
5361 }
5362
5363 #-> sub CPAN::Index::read_metadata_cache ;
5364 sub read_metadata_cache {
5365     my($self) = @_;
5366     return unless $CPAN::Config->{'cache_metadata'};
5367     return if CPAN::_sqlite_running;
5368     return unless $CPAN::META->has_usable("Storable");
5369     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
5370     return unless -r $metadata_file and -f $metadata_file;
5371     $CPAN::Frontend->myprint("Going to read $metadata_file\n");
5372     my $cache;
5373     eval { $cache = Storable::retrieve($metadata_file) };
5374     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
5375     if (!$cache || !UNIVERSAL::isa($cache, 'HASH')) {
5376         $LAST_TIME = 0;
5377         return;
5378     }
5379     if (exists $cache->{PROTOCOL}) {
5380         if (PROTOCOL > $cache->{PROTOCOL}) {
5381             $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
5382                                             "with protocol v%s, requiring v%s\n",
5383                                             $cache->{PROTOCOL},
5384                                             PROTOCOL)
5385                                    );
5386             return;
5387         }
5388     } else {
5389         $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
5390                                 "with protocol v1.0\n");
5391         return;
5392     }
5393     my $clcnt = 0;
5394     my $idcnt = 0;
5395     while(my($class,$v) = each %$cache) {
5396         next unless $class =~ /^CPAN::/;
5397         $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
5398         while (my($id,$ro) = each %$v) {
5399             $CPAN::META->{readwrite}{$class}{$id} ||=
5400                 $class->new(ID=>$id, RO=>$ro);
5401             $idcnt++;
5402         }
5403         $clcnt++;
5404     }
5405     unless ($clcnt) { # sanity check
5406         $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
5407         return;
5408     }
5409     if ($idcnt < 1000) {
5410         $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
5411                                  "in $metadata_file\n");
5412         return;
5413     }
5414     $CPAN::META->{PROTOCOL} ||=
5415         $cache->{PROTOCOL}; # reading does not up or downgrade, but it
5416                             # does initialize to some protocol
5417     $LAST_TIME = $cache->{last_time};
5418     $DATE_OF_02 = $cache->{DATE_OF_02};
5419     $CPAN::Frontend->myprint("  Database was generated on $DATE_OF_02\n")
5420         if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
5421     return;
5422 }
5423
5424 package CPAN::InfoObj;
5425 use strict;
5426
5427 sub ro {
5428     my $self = shift;
5429     exists $self->{RO} and return $self->{RO};
5430 }
5431
5432 #-> sub CPAN::InfoObj::cpan_userid
5433 sub cpan_userid {
5434     my $self = shift;
5435     my $ro = $self->ro;
5436     if ($ro) {
5437         return $ro->{CPAN_USERID} || "N/A";
5438     } else {
5439         $self->debug("ID[$self->{ID}]");
5440         # N/A for bundles found locally
5441         return "N/A";
5442     }
5443 }
5444
5445 sub id { shift->{ID}; }
5446
5447 #-> sub CPAN::InfoObj::new ;
5448 sub new {
5449     my $this = bless {}, shift;
5450     %$this = @_;
5451     $this
5452 }
5453
5454 # The set method may only be used by code that reads index data or
5455 # otherwise "objective" data from the outside world. All session
5456 # related material may do anything else with instance variables but
5457 # must not touch the hash under the RO attribute. The reason is that
5458 # the RO hash gets written to Metadata file and is thus persistent.
5459
5460 #-> sub CPAN::InfoObj::safe_chdir ;
5461 sub safe_chdir {
5462   my($self,$todir) = @_;
5463   # we die if we cannot chdir and we are debuggable
5464   Carp::confess("safe_chdir called without todir argument")
5465         unless defined $todir and length $todir;
5466   if (chdir $todir) {
5467     $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
5468         if $CPAN::DEBUG;
5469   } else {
5470     if (-e $todir) {
5471         unless (-x $todir) {
5472             unless (chmod 0755, $todir) {
5473                 my $cwd = CPAN::anycwd();
5474                 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
5475                                         "permission to change the permission; cannot ".
5476                                         "chdir to '$todir'\n");
5477                 $CPAN::Frontend->mysleep(5);
5478                 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
5479                                        qq{to todir[$todir]: $!});
5480             }
5481         }
5482     } else {
5483         $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n");
5484     }
5485     if (chdir $todir) {
5486       $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
5487           if $CPAN::DEBUG;
5488     } else {
5489       my $cwd = CPAN::anycwd();
5490       $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
5491                              qq{to todir[$todir] (a chmod has been issued): $!});
5492     }
5493   }
5494 }
5495
5496 #-> sub CPAN::InfoObj::set ;
5497 sub set {
5498     my($self,%att) = @_;
5499     my $class = ref $self;
5500
5501     # This must be ||=, not ||, because only if we write an empty
5502     # reference, only then the set method will write into the readonly
5503     # area. But for Distributions that spring into existence, maybe
5504     # because of a typo, we do not like it that they are written into
5505     # the readonly area and made permanent (at least for a while) and
5506     # that is why we do not "allow" other places to call ->set.
5507     unless ($self->id) {
5508         CPAN->debug("Bug? Empty ID, rejecting");
5509         return;
5510     }
5511     my $ro = $self->{RO} =
5512         $CPAN::META->{readonly}{$class}{$self->id} ||= {};
5513
5514     while (my($k,$v) = each %att) {
5515         $ro->{$k} = $v;
5516     }
5517 }
5518
5519 #-> sub CPAN::InfoObj::as_glimpse ;
5520 sub as_glimpse {
5521     my($self) = @_;
5522     my(@m);
5523     my $class = ref($self);
5524     $class =~ s/^CPAN:://;
5525     my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID};
5526     push @m, sprintf "%-15s %s\n", $class, $id;
5527     join "", @m;
5528 }
5529
5530 #-> sub CPAN::InfoObj::as_string ;
5531 sub as_string {
5532     my($self) = @_;
5533     my(@m);
5534     my $class = ref($self);
5535     $class =~ s/^CPAN:://;
5536     push @m, $class, " id = $self->{ID}\n";
5537     my $ro;
5538     unless ($ro = $self->ro) {
5539         if (substr($self->{ID},-1,1) eq ".") { # directory
5540             $ro = +{};
5541         } else {
5542             $CPAN::Frontend->mywarn("Unknown object $self->{ID}\n");
5543             $CPAN::Frontend->mysleep(5);
5544             return;
5545         }
5546     }
5547     for (sort keys %$ro) {
5548         # next if m/^(ID|RO)$/;
5549         my $extra = "";
5550         if ($_ eq "CPAN_USERID") {
5551             $extra .= " (";
5552             $extra .= $self->fullname;
5553             my $email; # old perls!
5554             if ($email = $CPAN::META->instance("CPAN::Author",
5555                                                $self->cpan_userid
5556                                               )->email) {
5557                 $extra .= " <$email>";
5558             } else {
5559                 $extra .= " <no email>";
5560             }
5561             $extra .= ")";
5562         } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
5563             push @m, sprintf "    %-12s %s\n", $_, $self->fullname;
5564             next;
5565         }
5566         next unless defined $ro->{$_};
5567         push @m, sprintf "    %-12s %s%s\n", $_, $ro->{$_}, $extra;
5568     }
5569   KEY: for (sort keys %$self) {
5570         next if m/^(ID|RO)$/;
5571         unless (defined $self->{$_}) {
5572             delete $self->{$_};
5573             next KEY;
5574         }
5575         if (ref($self->{$_}) eq "ARRAY") {
5576             push @m, sprintf "    %-12s %s\n", $_, "@{$self->{$_}}";
5577         } elsif (ref($self->{$_}) eq "HASH") {
5578             my $value;
5579             if (/^CONTAINSMODS$/) {
5580                 $value = join(" ",sort keys %{$self->{$_}});
5581             } elsif (/^prereq_pm$/) {
5582                 my @value;
5583                 my $v = $self->{$_};
5584                 for my $x (sort keys %$v) {
5585                     my @svalue;
5586                     for my $y (sort keys %{$v->{$x}}) {
5587                         push @svalue, "$y=>$v->{$x}{$y}";
5588                     }
5589                     push @value, "$x\:" . join ",", @svalue if @svalue;
5590                 }
5591                 $value = join ";", @value;
5592             } else {
5593                 $value = $self->{$_};
5594             }
5595             push @m, sprintf(
5596                              "    %-12s %s\n",
5597                              $_,
5598                              $value,
5599                             );
5600         } else {
5601             push @m, sprintf "    %-12s %s\n", $_, $self->{$_};
5602         }
5603     }
5604     join "", @m, "\n";
5605 }
5606
5607 #-> sub CPAN::InfoObj::fullname ;
5608 sub fullname {
5609     my($self) = @_;
5610     $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
5611 }
5612
5613 #-> sub CPAN::InfoObj::dump ;
5614 sub dump {
5615     my($self, $what) = @_;
5616     unless ($CPAN::META->has_inst("Data::Dumper")) {
5617         $CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
5618     }
5619     local $Data::Dumper::Sortkeys;
5620     $Data::Dumper::Sortkeys = 1;
5621     my $out = Data::Dumper::Dumper($what ? eval $what : $self);
5622     if (length $out > 100000) {
5623         my $fh_pager = FileHandle->new;
5624         local($SIG{PIPE}) = "IGNORE";
5625         my $pager = $CPAN::Config->{'pager'} || "cat";
5626         $fh_pager->open("|$pager")
5627             or die "Could not open pager $pager\: $!";
5628         $fh_pager->print($out);
5629         close $fh_pager;
5630     } else {
5631         $CPAN::Frontend->myprint($out);
5632     }
5633 }
5634
5635 package CPAN::Author;
5636 use strict;
5637
5638 #-> sub CPAN::Author::force
5639 sub force {
5640     my $self = shift;
5641     $self->{force}++;
5642 }
5643
5644 #-> sub CPAN::Author::force
5645 sub unforce {
5646     my $self = shift;
5647     delete $self->{force};
5648 }
5649
5650 #-> sub CPAN::Author::id
5651 sub id {
5652     my $self = shift;
5653     my $id = $self->{ID};
5654     $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
5655     $id;
5656 }
5657
5658 #-> sub CPAN::Author::as_glimpse ;
5659 sub as_glimpse {
5660     my($self) = @_;
5661     my(@m);
5662     my $class = ref($self);
5663     $class =~ s/^CPAN:://;
5664     push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
5665                      $class,
5666                      $self->{ID},
5667                      $self->fullname,
5668                      $self->email);
5669     join "", @m;
5670 }
5671
5672 #-> sub CPAN::Author::fullname ;
5673 sub fullname {
5674     shift->ro->{FULLNAME};
5675 }
5676 *name = \&fullname;
5677
5678 #-> sub CPAN::Author::email ;
5679 sub email    { shift->ro->{EMAIL}; }
5680
5681 #-> sub CPAN::Author::ls ;
5682 sub ls {
5683     my $self = shift;
5684     my $glob = shift || "";
5685     my $silent = shift || 0;
5686     my $id = $self->id;
5687
5688     # adapted from CPAN::Distribution::verifyCHECKSUM ;
5689     my(@csf); # chksumfile
5690     @csf = $self->id =~ /(.)(.)(.*)/;
5691     $csf[1] = join "", @csf[0,1];
5692     $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
5693     my(@dl);
5694     @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
5695     unless (grep {$_->[2] eq $csf[1]} @dl) {
5696         $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
5697         return;
5698     }
5699     @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
5700     unless (grep {$_->[2] eq $csf[2]} @dl) {
5701         $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
5702         return;
5703     }
5704     @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
5705     if ($glob) {
5706         if ($CPAN::META->has_inst("Text::Glob")) {
5707             my $rglob = Text::Glob::glob_to_regex($glob);
5708             @dl = grep { $_->[2] =~ /$rglob/ } @dl;
5709         } else {
5710             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
5711         }
5712     }
5713     unless ($silent >= 2) {
5714         $CPAN::Frontend->myprint(join "", map {
5715             sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
5716         } sort { $a->[2] cmp $b->[2] } @dl);
5717     }
5718     @dl;
5719 }
5720
5721 # returns an array of arrays, the latter contain (size,mtime,filename)
5722 #-> sub CPAN::Author::dir_listing ;
5723 sub dir_listing {
5724     my $self = shift;
5725     my $chksumfile = shift;
5726     my $recursive = shift;
5727     my $may_ftp = shift;
5728
5729     my $lc_want =
5730         File::Spec->catfile($CPAN::Config->{keep_source_where},
5731                             "authors", "id", @$chksumfile);
5732
5733     my $fh;
5734
5735     # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
5736     # hazard.  (Without GPG installed they are not that much better,
5737     # though.)
5738     $fh = FileHandle->new;
5739     if (open($fh, $lc_want)) {
5740         my $line = <$fh>; close $fh;
5741         unlink($lc_want) unless $line =~ /PGP/;
5742     }
5743
5744     local($") = "/";
5745     # connect "force" argument with "index_expire".
5746     my $force = $self->{force};
5747     if (my @stat = stat $lc_want) {
5748         $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
5749     }
5750     my $lc_file;
5751     if ($may_ftp) {
5752         $lc_file = CPAN::FTP->localize(
5753                                        "authors/id/@$chksumfile",
5754                                        $lc_want,
5755                                        $force,
5756                                       );
5757         unless ($lc_file) {
5758             $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
5759             $chksumfile->[-1] .= ".gz";
5760             $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
5761                                            "$lc_want.gz",1);
5762             if ($lc_file) {
5763                 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
5764                 eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
5765             } else {
5766                 return;
5767             }
5768         }
5769     } else {
5770         $lc_file = $lc_want;
5771         # we *could* second-guess and if the user has a file: URL,
5772         # then we could look there. But on the other hand, if they do
5773         # have a file: URL, wy did they choose to set
5774         # $CPAN::Config->{show_upload_date} to false?
5775     }
5776
5777     # adapted from CPAN::Distribution::CHECKSUM_check_file ;
5778     $fh = FileHandle->new;
5779     my($cksum);
5780     if (open $fh, $lc_file) {
5781         local($/);
5782         my $eval = <$fh>;
5783         $eval =~ s/\015?\012/\n/g;
5784         close $fh;
5785         my($comp) = Safe->new();
5786         $cksum = $comp->reval($eval);
5787         if ($@) {
5788             rename $lc_file, "$lc_file.bad";
5789             Carp::confess($@) if $@;
5790         }
5791     } elsif ($may_ftp) {
5792         Carp::carp "Could not open '$lc_file' for reading.";
5793     } else {
5794         # Maybe should warn: "You may want to set show_upload_date to a true value"
5795         return;
5796     }
5797     my(@result,$f);
5798     for $f (sort keys %$cksum) {
5799         if (exists $cksum->{$f}{isdir}) {
5800             if ($recursive) {
5801                 my(@dir) = @$chksumfile;
5802                 pop @dir;
5803                 push @dir, $f, "CHECKSUMS";
5804                 push @result, map {
5805                     [$_->[0], $_->[1], "$f/$_->[2]"]
5806                 } $self->dir_listing(\@dir,1,$may_ftp);
5807             } else {
5808                 push @result, [ 0, "-", $f ];
5809             }
5810         } else {
5811             push @result, [
5812                            ($cksum->{$f}{"size"}||0),
5813                            $cksum->{$f}{"mtime"}||"---",
5814                            $f
5815                           ];
5816         }
5817     }
5818     @result;
5819 }
5820
5821 #-> sub CPAN::Author::reports
5822 sub reports {
5823     $CPAN::Frontend->mywarn("reports on authors not implemented.
5824 Please file a bugreport if you need this.\n");
5825 }
5826
5827 package CPAN::Distribution;
5828 use strict;
5829
5830 # Accessors
5831 sub cpan_comment {
5832     my $self = shift;
5833     my $ro = $self->ro or return;
5834     $ro->{CPAN_COMMENT}
5835 }
5836
5837 #-> CPAN::Distribution::undelay
5838 sub undelay {
5839     my $self = shift;
5840     for my $delayer (
5841                      "configure_requires_later",
5842                      "configure_requires_later_for",
5843                      "later",
5844                      "later_for",
5845                     ) {
5846         delete $self->{$delayer};
5847     }
5848 }
5849
5850 #-> CPAN::Distribution::is_dot_dist
5851 sub is_dot_dist {
5852     my($self) = @_;
5853     return substr($self->id,-1,1) eq ".";
5854 }
5855
5856 # add the A/AN/ stuff
5857 #-> CPAN::Distribution::normalize
5858 sub normalize {
5859     my($self,$s) = @_;
5860     $s = $self->id unless defined $s;
5861     if (substr($s,-1,1) eq ".") {
5862         # using a global because we are sometimes called as static method
5863         if (!$CPAN::META->{LOCK}
5864             && !$CPAN::Have_warned->{"$s is unlocked"}++
5865            ) {
5866             $CPAN::Frontend->mywarn("You are visiting the local directory
5867   '$s'
5868   without lock, take care that concurrent processes do not do likewise.\n");
5869             $CPAN::Frontend->mysleep(1);
5870         }
5871         if ($s eq ".") {
5872             $s = "$CPAN::iCwd/.";
5873         } elsif (File::Spec->file_name_is_absolute($s)) {
5874         } elsif (File::Spec->can("rel2abs")) {
5875             $s = File::Spec->rel2abs($s);
5876         } else {
5877             $CPAN::Frontend->mydie("Your File::Spec is too old, please upgrade File::Spec");
5878         }
5879         CPAN->debug("s[$s]") if $CPAN::DEBUG;
5880         unless ($CPAN::META->exists("CPAN::Distribution", $s)) {
5881             for ($CPAN::META->instance("CPAN::Distribution", $s)) {
5882                 $_->{build_dir} = $s;
5883                 $_->{archived} = "local_directory";
5884                 $_->{unwrapped} = CPAN::Distrostatus->new("YES -- local_directory");
5885             }
5886         }
5887     } elsif (
5888         $s =~ tr|/|| == 1
5889         or
5890         $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
5891        ) {
5892         return $s if $s =~ m:^N/A|^Contact Author: ;
5893         $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
5894             $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
5895         CPAN->debug("s[$s]") if $CPAN::DEBUG;
5896     }
5897     $s;
5898 }
5899
5900 #-> sub CPAN::Distribution::author ;
5901 sub author {
5902     my($self) = @_;
5903     my($authorid);
5904     if (substr($self->id,-1,1) eq ".") {
5905         $authorid = "LOCAL";
5906     } else {
5907         ($authorid) = $self->pretty_id =~ /^([\w\-]+)/;
5908     }
5909     CPAN::Shell->expand("Author",$authorid);
5910 }
5911
5912 # tries to get the yaml from CPAN instead of the distro itself:
5913 # EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels
5914 sub fast_yaml {
5915     my($self) = @_;
5916     my $meta = $self->pretty_id;
5917     $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/;
5918     my(@ls) = CPAN::Shell->globls($meta);
5919     my $norm = $self->normalize($meta);
5920
5921     my($local_file);
5922     my($local_wanted) =
5923         File::Spec->catfile(
5924                             $CPAN::Config->{keep_source_where},
5925                             "authors",
5926                             "id",
5927                             split(/\//,$norm)
5928                            );
5929     $self->debug("Doing localize") if $CPAN::DEBUG;
5930     unless ($local_file =
5931             CPAN::FTP->localize("authors/id/$norm",
5932                                 $local_wanted)) {
5933         $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n");
5934     }
5935     my $yaml = CPAN->_yaml_loadfile($local_file)->[0];
5936 }
5937
5938 #-> sub CPAN::Distribution::cpan_userid
5939 sub cpan_userid {
5940     my $self = shift;
5941     if ($self->{ID} =~ m{[A-Z]/[A-Z\-]{2}/([A-Z\-]+)/}) {
5942         return $1;
5943     }
5944     return $self->SUPER::cpan_userid;
5945 }
5946
5947 #-> sub CPAN::Distribution::pretty_id
5948 sub pretty_id {
5949     my $self = shift;
5950     my $id = $self->id;
5951     return $id unless $id =~ m|^./../|;
5952     substr($id,5);
5953 }
5954
5955 #-> sub CPAN::Distribution::base_id
5956 sub base_id {
5957     my $self = shift;
5958     my $id = $self->pretty_id();
5959     my $base_id = File::Basename::basename($id);
5960     $base_id =~ s{\.(?:tar\.(bz2|gz|Z)|t(?:gz|bz)|zip)$}{}i;
5961     return $base_id;
5962 }
5963
5964 # mark as dirty/clean for the sake of recursion detection. $color=1
5965 # means "in use", $color=0 means "not in use anymore". $color=2 means
5966 # we have determined prereqs now and thus insist on passing this
5967 # through (at least) once again.
5968
5969 #-> sub CPAN::Distribution::color_cmd_tmps ;
5970 sub color_cmd_tmps {
5971     my($self) = shift;
5972     my($depth) = shift || 0;
5973     my($color) = shift || 0;
5974     my($ancestors) = shift || [];
5975     # a distribution needs to recurse into its prereq_pms
5976
5977     return if exists $self->{incommandcolor}
5978         && $color==1
5979         && $self->{incommandcolor}==$color;
5980     if ($depth>=$CPAN::MAX_RECURSION) {
5981         die(CPAN::Exception::RecursiveDependency->new($ancestors));
5982     }
5983     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5984     my $prereq_pm = $self->prereq_pm;
5985     if (defined $prereq_pm) {
5986       PREREQ: for my $pre (keys %{$prereq_pm->{requires}||{}},
5987                            keys %{$prereq_pm->{build_requires}||{}}) {
5988             next PREREQ if $pre eq "perl";
5989             my $premo;
5990             unless ($premo = CPAN::Shell->expand("Module",$pre)) {
5991                 $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n");
5992                 $CPAN::Frontend->mysleep(2);
5993                 next PREREQ;
5994             }
5995             $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5996         }
5997     }
5998     if ($color==0) {
5999         delete $self->{sponsored_mods};
6000
6001         # as we are at the end of a command, we'll give up this
6002         # reminder of a broken test. Other commands may test this guy
6003         # again. Maybe 'badtestcnt' should be renamed to
6004         # 'make_test_failed_within_command'?
6005         delete $self->{badtestcnt};
6006     }
6007     $self->{incommandcolor} = $color;
6008 }
6009
6010 #-> sub CPAN::Distribution::as_string ;
6011 sub as_string {
6012     my $self = shift;
6013     $self->containsmods;
6014     $self->upload_date;
6015     $self->SUPER::as_string(@_);
6016 }
6017
6018 #-> sub CPAN::Distribution::containsmods ;
6019 sub containsmods {
6020     my $self = shift;
6021     return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
6022     my $dist_id = $self->{ID};
6023     for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
6024         my $mod_file = $mod->cpan_file or next;
6025         my $mod_id = $mod->{ID} or next;
6026         # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
6027         # sleep 1;
6028         if ($CPAN::Signal) {
6029             delete $self->{CONTAINSMODS};
6030             return;
6031         }
6032         $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
6033     }
6034     keys %{$self->{CONTAINSMODS}||={}};
6035 }
6036
6037 #-> sub CPAN::Distribution::upload_date ;
6038 sub upload_date {
6039     my $self = shift;
6040     return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
6041     my(@local_wanted) = split(/\//,$self->id);
6042     my $filename = pop @local_wanted;
6043     push @local_wanted, "CHECKSUMS";
6044     my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
6045     return unless $author;
6046     my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
6047     return unless @dl;
6048     my($dirent) = grep { $_->[2] eq $filename } @dl;
6049     # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
6050     return unless $dirent->[1];
6051     return $self->{UPLOAD_DATE} = $dirent->[1];
6052 }
6053
6054 #-> sub CPAN::Distribution::uptodate ;
6055 sub uptodate {
6056     my($self) = @_;
6057     my $c;
6058     foreach $c ($self->containsmods) {
6059         my $obj = CPAN::Shell->expandany($c);
6060         unless ($obj->uptodate) {
6061             my $id = $self->pretty_id;
6062             $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG;
6063             return 0;
6064         }
6065     }
6066     return 1;
6067 }
6068
6069 #-> sub CPAN::Distribution::called_for ;
6070 sub called_for {
6071     my($self,$id) = @_;
6072     $self->{CALLED_FOR} = $id if defined $id;
6073     return $self->{CALLED_FOR};
6074 }
6075
6076 #-> sub CPAN::Distribution::get ;
6077 sub get {
6078     my($self) = @_;
6079     $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
6080     if (my $goto = $self->prefs->{goto}) {
6081         $CPAN::Frontend->mywarn
6082             (sprintf(
6083                      "delegating to '%s' as specified in prefs file '%s' doc %d\n",
6084                      $goto,
6085                      $self->{prefs_file},
6086                      $self->{prefs_file_doc},
6087                     ));
6088         return $self->goto($goto);
6089     }
6090     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
6091                            ? $ENV{PERL5LIB}
6092                            : ($ENV{PERLLIB} || "");
6093
6094     $CPAN::META->set_perl5lib;
6095     local $ENV{MAKEFLAGS}; # protect us from outer make calls
6096
6097   EXCUSE: {
6098         my @e;
6099         my $goodbye_message;
6100         $self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG;
6101         if ($self->prefs->{disabled}) {
6102             my $why = sprintf(
6103                               "Disabled via prefs file '%s' doc %d",
6104                               $self->{prefs_file},
6105                               $self->{prefs_file_doc},
6106                              );
6107             push @e, $why;
6108             $self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
6109             $goodbye_message = "[disabled] -- NA $why";
6110             # note: not intended to be persistent but at least visible
6111             # during this session
6112         } else {
6113             if (exists $self->{build_dir} && -d $self->{build_dir}
6114                 && ($self->{modulebuild}||$self->{writemakefile})
6115                ) {
6116                 # this deserves print, not warn:
6117                 $CPAN::Frontend->myprint("  Has already been unwrapped into directory ".
6118                                          "$self->{build_dir}\n"
6119                                         );
6120                 return 1;
6121             }
6122
6123             # although we talk about 'force' we shall not test on
6124             # force directly. New model of force tries to refrain from
6125             # direct checking of force.
6126             exists $self->{unwrapped} and (
6127                                            UNIVERSAL::can($self->{unwrapped},"failed") ?
6128                                            $self->{unwrapped}->failed :
6129                                            $self->{unwrapped} =~ /^NO/
6130                                           )
6131                 and push @e, "Unwrapping had some problem, won't try again without force";
6132         }
6133         if (@e) {
6134             $CPAN::Frontend->mywarn(join "", map {"$_\n"} @e);
6135             if ($goodbye_message) {
6136                  $self->goodbye($goodbye_message);
6137             }
6138             return;
6139         }
6140     }
6141     my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
6142
6143     my($local_file);
6144     unless ($self->{build_dir} && -d $self->{build_dir}) {
6145         $self->get_file_onto_local_disk;
6146         return if $CPAN::Signal;
6147         $self->check_integrity;
6148         return if $CPAN::Signal;
6149         (my $packagedir,$local_file) = $self->run_preps_on_packagedir;
6150         $packagedir ||= $self->{build_dir};
6151         $self->{build_dir} = $packagedir;
6152     }
6153
6154     if ($CPAN::Signal) {
6155         $self->safe_chdir($sub_wd);
6156         return;
6157     }
6158     return $self->run_MM_or_MB($local_file);
6159 }
6160
6161 #-> CPAN::Distribution::get_file_onto_local_disk
6162 sub get_file_onto_local_disk {
6163     my($self) = @_;
6164
6165     return if $self->is_dot_dist;
6166     my($local_file);
6167     my($local_wanted) =
6168         File::Spec->catfile(
6169                             $CPAN::Config->{keep_source_where},
6170                             "authors",
6171                             "id",
6172                             split(/\//,$self->id)
6173                            );
6174
6175     $self->debug("Doing localize") if $CPAN::DEBUG;
6176     unless ($local_file =
6177             CPAN::FTP->localize("authors/id/$self->{ID}",
6178                                 $local_wanted)) {
6179         my $note = "";
6180         if ($CPAN::Index::DATE_OF_02) {
6181             $note = "Note: Current database in memory was generated ".
6182                 "on $CPAN::Index::DATE_OF_02\n";
6183         }
6184         $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
6185     }
6186
6187     $self->debug("local_wanted[$local_wanted]local_file[$local_file]") if $CPAN::DEBUG;
6188     $self->{localfile} = $local_file;
6189 }
6190
6191
6192 #-> CPAN::Distribution::check_integrity
6193 sub check_integrity {
6194     my($self) = @_;
6195
6196     return if $self->is_dot_dist;
6197     if ($CPAN::META->has_inst("Digest::SHA")) {
6198         $self->debug("Digest::SHA is installed, verifying");
6199         $self->verifyCHECKSUM;
6200     } else {
6201         $self->debug("Digest::SHA is NOT installed");
6202     }
6203 }
6204
6205 #-> CPAN::Distribution::run_preps_on_packagedir
6206 sub run_preps_on_packagedir {
6207     my($self) = @_;
6208     return if $self->is_dot_dist;
6209
6210     $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
6211     my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
6212     $self->safe_chdir($builddir);
6213     $self->debug("Removing tmp-$$") if $CPAN::DEBUG;
6214     File::Path::rmtree("tmp-$$");
6215     unless (mkdir "tmp-$$", 0755) {
6216         $CPAN::Frontend->unrecoverable_error(<<EOF);
6217 Couldn't mkdir '$builddir/tmp-$$': $!
6218
6219 Cannot continue: Please find the reason why I cannot make the
6220 directory
6221 $builddir/tmp-$$
6222 and fix the problem, then retry.
6223
6224 EOF
6225     }
6226     if ($CPAN::Signal) {
6227         return;
6228     }
6229     $self->safe_chdir("tmp-$$");
6230
6231     #
6232     # Unpack the goods
6233     #
6234     my $local_file = $self->{localfile};
6235     my $ct = eval{CPAN::Tarzip->new($local_file)};
6236     unless ($ct) {
6237         $self->{unwrapped} = CPAN::Distrostatus->new("NO");
6238         delete $self->{build_dir};
6239         return;
6240     }
6241     if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i) {
6242         $self->{was_uncompressed}++ unless eval{$ct->gtest()};
6243         $self->untar_me($ct);
6244     } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
6245         $self->unzip_me($ct);
6246     } else {
6247         $self->{was_uncompressed}++ unless $ct->gtest();
6248         $local_file = $self->handle_singlefile($local_file);
6249     }
6250
6251     # we are still in the tmp directory!
6252     # Let's check if the package has its own directory.
6253     my $dh = DirHandle->new(File::Spec->curdir)
6254         or Carp::croak("Couldn't opendir .: $!");
6255     my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
6256     $dh->close;
6257     my ($packagedir);
6258     # XXX here we want in each branch File::Temp to protect all build_dir directories
6259     if (CPAN->has_usable("File::Temp")) {
6260         my $tdir_base;
6261         my $from_dir;
6262         my @dirents;
6263         if (@readdir == 1 && -d $readdir[0]) {
6264             $tdir_base = $readdir[0];
6265             $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]);
6266             my $dh2 = DirHandle->new($from_dir)
6267                 or Carp::croak("Couldn't opendir $from_dir: $!");
6268             @dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC??
6269         } else {
6270             my $userid = $self->cpan_userid;
6271             CPAN->debug("userid[$userid]");
6272             if (!$userid or $userid eq "N/A") {
6273                 $userid = "anon";
6274             }
6275             $tdir_base = $userid;
6276             $from_dir = File::Spec->curdir;
6277             @dirents = @readdir;
6278         }
6279         $packagedir = File::Temp::tempdir(
6280                                           "$tdir_base-XXXXXX",
6281                                           DIR => $builddir,
6282                                           CLEANUP => 0,
6283                                          );
6284         my $f;
6285         for $f (@dirents) { # is already without "." and ".."
6286             my $from = File::Spec->catdir($from_dir,$f);
6287             my $to = File::Spec->catdir($packagedir,$f);
6288             unless (File::Copy::move($from,$to)) {
6289                 my $err = $!;
6290                 $from = File::Spec->rel2abs($from);
6291                 Carp::confess("Couldn't move $from to $to: $err");
6292             }
6293         }
6294     } else { # older code below, still better than nothing when there is no File::Temp
6295         my($distdir);
6296         if (@readdir == 1 && -d $readdir[0]) {
6297             $distdir = $readdir[0];
6298             $packagedir = File::Spec->catdir($builddir,$distdir);
6299             $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
6300                 if $CPAN::DEBUG;
6301             -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
6302                                                         "$packagedir\n");
6303             File::Path::rmtree($packagedir);
6304             unless (File::Copy::move($distdir,$packagedir)) {
6305                 $CPAN::Frontend->unrecoverable_error(<<EOF);
6306 Couldn't move '$distdir' to '$packagedir': $!
6307
6308 Cannot continue: Please find the reason why I cannot move
6309 $builddir/tmp-$$/$distdir
6310 to
6311 $packagedir
6312 and fix the problem, then retry
6313
6314 EOF
6315             }
6316             $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
6317                                  $distdir,
6318                                  $packagedir,
6319                                  -e $packagedir,
6320                                  -d $packagedir,
6321                                 )) if $CPAN::DEBUG;
6322         } else {
6323             my $userid = $self->cpan_userid;
6324             CPAN->debug("userid[$userid]") if $CPAN::DEBUG;
6325             if (!$userid or $userid eq "N/A") {
6326                 $userid = "anon";
6327             }
6328             my $pragmatic_dir = $userid . '000';
6329             $pragmatic_dir =~ s/\W_//g;
6330             $pragmatic_dir++ while -d "../$pragmatic_dir";
6331             $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
6332             $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
6333             File::Path::mkpath($packagedir);
6334             my($f);
6335             for $f (@readdir) { # is already without "." and ".."
6336                 my $to = File::Spec->catdir($packagedir,$f);
6337                 File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
6338             }
6339         }
6340     }
6341     $self->{build_dir} = $packagedir;
6342     $self->safe_chdir($builddir);
6343     File::Path::rmtree("tmp-$$");
6344
6345     $self->safe_chdir($packagedir);
6346     $self->_signature_business();
6347     $self->safe_chdir($builddir);
6348
6349     return($packagedir,$local_file);
6350 }
6351
6352 #-> sub CPAN::Distribution::parse_meta_yml ;
6353 sub parse_meta_yml {
6354     my($self) = @_;
6355     my $build_dir = $self->{build_dir} or die "PANIC: cannot parse yaml without a build_dir";
6356     my $yaml = File::Spec->catfile($build_dir,"META.yml");
6357     $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
6358     return unless -f $yaml;
6359     my $early_yaml;
6360     eval {
6361         require Parse::Metayaml; # hypothetical
6362         $early_yaml = Parse::Metayaml::LoadFile($yaml)->[0];
6363     };
6364     unless ($early_yaml) {
6365         eval { $early_yaml = CPAN->_yaml_loadfile($yaml)->[0]; };
6366     }
6367     unless ($early_yaml) {
6368         return;
6369     }
6370     return $early_yaml;
6371 }
6372
6373 #-> sub CPAN::Distribution::satisfy_configure_requires ;
6374 sub satisfy_configure_requires {
6375     my($self) = @_;
6376     my $enable_configure_requires = 1;
6377     if (!$enable_configure_requires) {
6378         return 1;
6379         # if we return 1 here, everything is as before we introduced
6380         # configure_requires that means, things with
6381         # configure_requires simply fail, all others succeed
6382     }
6383     my @prereq = $self->unsat_prereq("configure_requires_later") or return 1;
6384     if ($self->{configure_requires_later}) {
6385         for my $k (keys %{$self->{configure_requires_later_for}||{}}) {
6386             if ($self->{configure_requires_later_for}{$k}>1) {
6387                 # we must not come here a second time
6388                 $CPAN::Frontend->mywarn("Panic: Some prerequisites is not available, please investigate...");
6389                 require YAML::Syck;
6390                 $CPAN::Frontend->mydie
6391                     (
6392                      YAML::Syck::Dump
6393                      ({self=>$self, prereq=>\@prereq})
6394                     );
6395             }
6396         }
6397     }
6398     if ($prereq[0][0] eq "perl") {
6399         my $need = "requires perl '$prereq[0][1]'";
6400         my $id = $self->pretty_id;
6401         $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
6402         $self->{make} = CPAN::Distrostatus->new("NO $need");
6403         $self->store_persistent_state;
6404         return $self->goodbye("[prereq] -- NOT OK");
6405     } else {
6406         my $follow = eval {
6407             $self->follow_prereqs("configure_requires_later", @prereq);
6408         };
6409         if (0) {
6410         } elsif ($follow) {
6411             return;
6412         } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
6413             $CPAN::Frontend->mywarn($@);
6414             return $self->goodbye("[depend] -- NOT OK");
6415         }
6416     }
6417     die "never reached";
6418 }
6419
6420 #-> sub CPAN::Distribution::run_MM_or_MB ;
6421 sub run_MM_or_MB {
6422     my($self,$local_file) = @_;
6423     $self->satisfy_configure_requires() or return;
6424     my($mpl) = File::Spec->catfile($self->{build_dir},"Makefile.PL");
6425     my($mpl_exists) = -f $mpl;
6426     unless ($mpl_exists) {
6427         # NFS has been reported to have racing problems after the
6428         # renaming of a directory in some environments.
6429         # This trick helps.
6430         $CPAN::Frontend->mysleep(1);
6431         my $mpldh = DirHandle->new($self->{build_dir})
6432             or Carp::croak("Couldn't opendir $self->{build_dir}: $!");
6433         $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
6434         $mpldh->close;
6435     }
6436     my $prefer_installer = "eumm"; # eumm|mb
6437     if (-f File::Spec->catfile($self->{build_dir},"Build.PL")) {
6438         if ($mpl_exists) { # they *can* choose
6439             if ($CPAN::META->has_inst("Module::Build")) {
6440                 $prefer_installer = CPAN::HandleConfig->prefs_lookup($self,
6441                                                                      q{prefer_installer});
6442             }
6443         } else {
6444             $prefer_installer = "mb";
6445         }
6446     }
6447     return unless $self->patch;
6448     if (lc($prefer_installer) eq "rand") {
6449         $prefer_installer = rand()<.5 ? "eumm" : "mb";
6450     }
6451     if (lc($prefer_installer) eq "mb") {
6452         $self->{modulebuild} = 1;
6453     } elsif ($self->{archived} eq "patch") {
6454         # not an edge case, nothing to install for sure
6455         my $why = "A patch file cannot be installed";
6456         $CPAN::Frontend->mywarn("Refusing to handle this file: $why\n");
6457         $self->{writemakefile} = CPAN::Distrostatus->new("NO $why");
6458     } elsif (! $mpl_exists) {
6459         $self->_edge_cases($mpl,$local_file);
6460     }
6461     if ($self->{build_dir}
6462         &&
6463         $CPAN::Config->{build_dir_reuse}
6464        ) {
6465         $self->store_persistent_state;
6466     }
6467     return $self;
6468 }
6469
6470 #-> CPAN::Distribution::store_persistent_state
6471 sub store_persistent_state {
6472     my($self) = @_;
6473     my $dir = $self->{build_dir};
6474     unless (File::Spec->canonpath(File::Basename::dirname($dir))
6475             eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
6476         $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
6477                                 "will not store persistent state\n");
6478         return;
6479     }
6480     my $file = sprintf "%s.yml", $dir;
6481     my $yaml_module = CPAN::_yaml_module;
6482     if ($CPAN::META->has_inst($yaml_module)) {
6483         CPAN->_yaml_dumpfile(
6484                              $file,
6485                              {
6486                               time => time,
6487                               perl => CPAN::_perl_fingerprint,
6488                               distribution => $self,
6489                              }
6490                             );
6491     } else {
6492         $CPAN::Frontend->myprint("Warning (usually harmless): '$yaml_module' not installed, ".
6493                                 "will not store persistent state\n");
6494     }
6495 }
6496
6497 #-> CPAN::Distribution::try_download
6498 sub try_download {
6499     my($self,$patch) = @_;
6500     my $norm = $self->normalize($patch);
6501     my($local_wanted) =
6502         File::Spec->catfile(
6503                             $CPAN::Config->{keep_source_where},
6504                             "authors",
6505                             "id",
6506                             split(/\//,$norm),
6507                            );
6508     $self->debug("Doing localize") if $CPAN::DEBUG;
6509     return CPAN::FTP->localize("authors/id/$norm",
6510                                $local_wanted);
6511 }
6512
6513 {
6514     my $stdpatchargs = "";
6515     #-> CPAN::Distribution::patch
6516     sub patch {
6517         my($self) = @_;
6518         $self->debug("checking patches id[$self->{ID}]") if $CPAN::DEBUG;
6519         my $patches = $self->prefs->{patches};
6520         $patches ||= "";
6521         $self->debug("patches[$patches]") if $CPAN::DEBUG;
6522         if ($patches) {
6523             return unless @$patches;
6524             $self->safe_chdir($self->{build_dir});
6525             CPAN->debug("patches[$patches]") if $CPAN::DEBUG;
6526             my $patchbin = $CPAN::Config->{patch};
6527             unless ($patchbin && length $patchbin) {
6528                 $CPAN::Frontend->mydie("No external patch command configured\n\n".
6529                                        "Please run 'o conf init /patch/'\n\n");
6530             }
6531             unless (MM->maybe_command($patchbin)) {
6532                 $CPAN::Frontend->mydie("No external patch command available\n\n".
6533                                        "Please run 'o conf init /patch/'\n\n");
6534             }
6535             $patchbin = CPAN::HandleConfig->safe_quote($patchbin);
6536             local $ENV{PATCH_GET} = 0; # formerly known as -g0
6537             unless ($stdpatchargs) {
6538                 my $system = "$patchbin --version |";
6539                 local *FH;
6540                 open FH, $system or die "Could not fork '$system': $!";
6541                 local $/ = "\n";
6542                 my $pversion;
6543               PARSEVERSION: while (<FH>) {
6544                     if (/^patch\s+([\d\.]+)/) {
6545                         $pversion = $1;
6546                         last PARSEVERSION;
6547                     }
6548                 }
6549                 if ($pversion) {
6550                     $stdpatchargs = "-N --fuzz=3";
6551                 } else {
6552                     $stdpatchargs = "-N";
6553                 }
6554             }
6555             my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches");
6556             $CPAN::Frontend->myprint("Going to apply $countedpatches:\n");
6557             for my $patch (@$patches) {
6558                 unless (-f $patch) {
6559                     if (my $trydl = $self->try_download($patch)) {
6560                         $patch = $trydl;
6561                     } else {
6562                         my $fail = "Could not find patch '$patch'";
6563                         $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6564                         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6565                         delete $self->{build_dir};
6566                         return;
6567                     }
6568                 }
6569                 $CPAN::Frontend->myprint("  $patch\n");
6570                 my $readfh = CPAN::Tarzip->TIEHANDLE($patch);
6571
6572                 my $pcommand;
6573                 my $ppp = $self->_patch_p_parameter($readfh);
6574                 if ($ppp eq "applypatch") {
6575                     $pcommand = "$CPAN::Config->{applypatch} -verbose";
6576                 } else {
6577                     my $thispatchargs = join " ", $stdpatchargs, $ppp;
6578                     $pcommand = "$patchbin $thispatchargs";
6579                 }
6580
6581                 $readfh = CPAN::Tarzip->TIEHANDLE($patch); # open again
6582                 my $writefh = FileHandle->new;
6583                 $CPAN::Frontend->myprint("  $pcommand\n");
6584                 unless (open $writefh, "|$pcommand") {
6585                     my $fail = "Could not fork '$pcommand'";
6586                     $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6587                     $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6588                     delete $self->{build_dir};
6589                     return;
6590                 }
6591                 while (my $x = $readfh->READLINE) {
6592                     print $writefh $x;
6593                 }
6594                 unless (close $writefh) {
6595                     my $fail = "Could not apply patch '$patch'";
6596                     $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6597                     $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6598                     delete $self->{build_dir};
6599                     return;
6600                 }
6601             }
6602             $self->{patched}++;
6603         }
6604         return 1;
6605     }
6606 }
6607
6608 sub _patch_p_parameter {
6609     my($self,$fh) = @_;
6610     my $cnt_files   = 0;
6611     my $cnt_p0files = 0;
6612     local($_);
6613     while ($_ = $fh->READLINE) {
6614         if (
6615             $CPAN::Config->{applypatch}
6616             &&
6617             /\#\#\#\# ApplyPatch data follows \#\#\#\#/
6618            ) {
6619             return "applypatch"
6620         }
6621         next unless /^[\*\+]{3}\s(\S+)/;
6622         my $file = $1;
6623         $cnt_files++;
6624         $cnt_p0files++ if -f $file;
6625         CPAN->debug("file[$file]cnt_files[$cnt_files]cnt_p0files[$cnt_p0files]")
6626             if $CPAN::DEBUG;
6627     }
6628     return "-p1" unless $cnt_files;
6629     return $cnt_files==$cnt_p0files ? "-p0" : "-p1";
6630 }
6631
6632 #-> sub CPAN::Distribution::_edge_cases
6633 # with "configure" or "Makefile" or single file scripts
6634 sub _edge_cases {
6635     my($self,$mpl,$local_file) = @_;
6636     $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
6637                          $mpl,
6638                          CPAN::anycwd(),
6639                         )) if $CPAN::DEBUG;
6640     my $build_dir = $self->{build_dir};
6641     my($configure) = File::Spec->catfile($build_dir,"Configure");
6642     if (-f $configure) {
6643         # do we have anything to do?
6644         $self->{configure} = $configure;
6645     } elsif (-f File::Spec->catfile($build_dir,"Makefile")) {
6646         $CPAN::Frontend->mywarn(qq{
6647 Package comes with a Makefile and without a Makefile.PL.
6648 We\'ll try to build it with that Makefile then.
6649 });
6650         $self->{writemakefile} = CPAN::Distrostatus->new("YES");
6651         $CPAN::Frontend->mysleep(2);
6652     } else {
6653         my $cf = $self->called_for || "unknown";
6654         if ($cf =~ m|/|) {
6655             $cf =~ s|.*/||;
6656             $cf =~ s|\W.*||;
6657         }
6658         $cf =~ s|[/\\:]||g;     # risk of filesystem damage
6659         $cf = "unknown" unless length($cf);
6660         $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
6661   (The test -f "$mpl" returned false.)
6662   Writing one on our own (setting NAME to $cf)\a\n});
6663         $self->{had_no_makefile_pl}++;
6664         $CPAN::Frontend->mysleep(3);
6665
6666         # Writing our own Makefile.PL
6667
6668         my $script = "";
6669         if ($self->{archived} eq "maybe_pl") {
6670             my $fh = FileHandle->new;
6671             my $script_file = File::Spec->catfile($build_dir,$local_file);
6672             $fh->open($script_file)
6673                 or Carp::croak("Could not open script '$script_file': $!");
6674             local $/ = "\n";
6675             # name parsen und prereq
6676             my($state) = "poddir";
6677             my($name, $prereq) = ("", "");
6678             while (<$fh>) {
6679                 if ($state eq "poddir" && /^=head\d\s+(\S+)/) {
6680                     if ($1 eq 'NAME') {
6681                         $state = "name";
6682                     } elsif ($1 eq 'PREREQUISITES') {
6683                         $state = "prereq";
6684                     }
6685                 } elsif ($state =~ m{^(name|prereq)$}) {
6686                     if (/^=/) {
6687                         $state = "poddir";
6688                     } elsif (/^\s*$/) {
6689                         # nop
6690                     } elsif ($state eq "name") {
6691                         if ($name eq "") {
6692                             ($name) = /^(\S+)/;
6693                             $state = "poddir";
6694                         }
6695                     } elsif ($state eq "prereq") {
6696                         $prereq .= $_;
6697                     }
6698                 } elsif (/^=cut\b/) {
6699                     last;
6700                 }
6701             }
6702             $fh->close;
6703
6704             for ($name) {
6705                 s{.*<}{};       # strip X<...>
6706                 s{>.*}{};
6707             }
6708             chomp $prereq;
6709             $prereq = join " ", split /\s+/, $prereq;
6710             my($PREREQ_PM) = join("\n", map {
6711                 s{.*<}{};       # strip X<...>
6712                 s{>.*}{};
6713                 if (/[\s\'\"]/) { # prose?
6714                 } else {
6715                     s/[^\w:]$//; # period?
6716                     " "x28 . "'$_' => 0,";
6717                 }
6718             } split /\s*,\s*/, $prereq);
6719
6720             $script = "
6721               EXE_FILES => ['$name'],
6722               PREREQ_PM => {
6723 $PREREQ_PM
6724                            },
6725 ";
6726             if ($name) {
6727                 my $to_file = File::Spec->catfile($build_dir, $name);
6728                 rename $script_file, $to_file
6729                     or die "Can't rename $script_file to $to_file: $!";
6730             }
6731         }
6732
6733         my $fh = FileHandle->new;
6734         $fh->open(">$mpl")
6735             or Carp::croak("Could not open >$mpl: $!");
6736         $fh->print(
6737                    qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
6738 # because there was no Makefile.PL supplied.
6739 # Autogenerated on: }.scalar localtime().qq{
6740
6741 use ExtUtils::MakeMaker;
6742 WriteMakefile(
6743               NAME => q[$cf],$script
6744              );
6745 });
6746         $fh->close;
6747     }
6748 }
6749
6750 #-> CPAN::Distribution::_signature_business
6751 sub _signature_business {
6752     my($self) = @_;
6753     my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
6754                                                       q{check_sigs});
6755     if ($check_sigs) {
6756         if ($CPAN::META->has_inst("Module::Signature")) {
6757             if (-f "SIGNATURE") {
6758                 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
6759                 my $rv = Module::Signature::verify();
6760                 if ($rv != Module::Signature::SIGNATURE_OK() and
6761                     $rv != Module::Signature::SIGNATURE_MISSING()) {
6762                     $CPAN::Frontend->mywarn(
6763                                             qq{\nSignature invalid for }.
6764                                             qq{distribution file. }.
6765                                             qq{Please investigate.\n\n}
6766                                            );
6767
6768                     my $wrap =
6769                         sprintf(qq{I'd recommend removing %s. Some error occured    }.
6770                                 qq{while checking its signature, so it could        }.
6771                                 qq{be invalid. Maybe you have configured            }.
6772                                 qq{your 'urllist' with a bad URL. Please check this }.
6773                                 qq{array with 'o conf urllist' and retry. Or        }.
6774                                 qq{examine the distribution in a subshell. Try
6775   look %s
6776 and run
6777   cpansign -v
6778 },
6779                                 $self->{localfile},
6780                                 $self->pretty_id,
6781                                );
6782                     $self->{signature_verify} = CPAN::Distrostatus->new("NO");
6783                     $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
6784                     $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
6785                 } else {
6786                     $self->{signature_verify} = CPAN::Distrostatus->new("YES");
6787                     $self->debug("Module::Signature has verified") if $CPAN::DEBUG;
6788                 }
6789             } else {
6790                 $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n});
6791             }
6792         } else {
6793             $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
6794         }
6795     }
6796 }
6797
6798 #-> CPAN::Distribution::untar_me ;
6799 sub untar_me {
6800     my($self,$ct) = @_;
6801     $self->{archived} = "tar";
6802     if ($ct->untar()) {
6803         $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6804     } else {
6805         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed");
6806     }
6807 }
6808
6809 # CPAN::Distribution::unzip_me ;
6810 sub unzip_me {
6811     my($self,$ct) = @_;
6812     $self->{archived} = "zip";
6813     if ($ct->unzip()) {
6814         $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6815     } else {
6816         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed");
6817     }
6818     return;
6819 }
6820
6821 sub handle_singlefile {
6822     my($self,$local_file) = @_;
6823
6824     if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ) {
6825         $self->{archived} = "pm";
6826     } elsif ( $local_file =~ /\.patch(\.(gz|bz2))?(?!\n)\Z/ ) {
6827         $self->{archived} = "patch";
6828     } else {
6829         $self->{archived} = "maybe_pl";
6830     }
6831
6832     my $to = File::Basename::basename($local_file);
6833     if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
6834         if (eval{CPAN::Tarzip->new($local_file)->gunzip($to)}) {
6835             $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6836         } else {
6837             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- uncompressing failed");
6838         }
6839     } else {
6840         if (File::Copy::cp($local_file,".")) {
6841             $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6842         } else {
6843             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed");
6844         }
6845     }
6846     return $to;
6847 }
6848
6849 #-> sub CPAN::Distribution::new ;
6850 sub new {
6851     my($class,%att) = @_;
6852
6853     # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
6854
6855     my $this = { %att };
6856     return bless $this, $class;
6857 }
6858
6859 #-> sub CPAN::Distribution::look ;
6860 sub look {
6861     my($self) = @_;
6862
6863     if ($^O eq 'MacOS') {
6864       $self->Mac::BuildTools::look;
6865       return;
6866     }
6867
6868     if (  $CPAN::Config->{'shell'} ) {
6869         $CPAN::Frontend->myprint(qq{
6870 Trying to open a subshell in the build directory...
6871 });
6872     } else {
6873         $CPAN::Frontend->myprint(qq{
6874 Your configuration does not define a value for subshells.
6875 Please define it with "o conf shell <your shell>"
6876 });
6877         return;
6878     }
6879     my $dist = $self->id;
6880     my $dir;
6881     unless ($dir = $self->dir) {
6882         $self->get;
6883     }
6884     unless ($dir ||= $self->dir) {
6885         $CPAN::Frontend->mywarn(qq{
6886 Could not determine which directory to use for looking at $dist.
6887 });
6888         return;
6889     }
6890     my $pwd  = CPAN::anycwd();
6891     $self->safe_chdir($dir);
6892     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
6893     {
6894         local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
6895         $ENV{CPAN_SHELL_LEVEL} += 1;
6896         my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'});
6897         unless (system($shell) == 0) {
6898             my $code = $? >> 8;
6899             $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
6900         }
6901     }
6902     $self->safe_chdir($pwd);
6903 }
6904
6905 # CPAN::Distribution::cvs_import ;
6906 sub cvs_import {
6907     my($self) = @_;
6908     $self->get;
6909     my $dir = $self->dir;
6910
6911     my $package = $self->called_for;
6912     my $module = $CPAN::META->instance('CPAN::Module', $package);
6913     my $version = $module->cpan_version;
6914
6915     my $userid = $self->cpan_userid;
6916
6917     my $cvs_dir = (split /\//, $dir)[-1];
6918     $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
6919     my $cvs_root =
6920       $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
6921     my $cvs_site_perl =
6922       $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
6923     if ($cvs_site_perl) {
6924         $cvs_dir = "$cvs_site_perl/$cvs_dir";
6925     }
6926     my $cvs_log = qq{"imported $package $version sources"};
6927     $version =~ s/\./_/g;
6928     # XXX cvs: undocumented and unclear how it was meant to work
6929     my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
6930                "$cvs_dir", $userid, "v$version");
6931
6932     my $pwd  = CPAN::anycwd();
6933     chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
6934
6935     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
6936
6937     $CPAN::Frontend->myprint(qq{@cmd\n});
6938     system(@cmd) == 0 or
6939     # XXX cvs
6940         $CPAN::Frontend->mydie("cvs import failed");
6941     chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
6942 }
6943
6944 #-> sub CPAN::Distribution::readme ;
6945 sub readme {
6946     my($self) = @_;
6947     my($dist) = $self->id;
6948     my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
6949     $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
6950     my($local_file);
6951     my($local_wanted) =
6952         File::Spec->catfile(
6953                             $CPAN::Config->{keep_source_where},
6954                             "authors",
6955                             "id",
6956                             split(/\//,"$sans.readme"),
6957                            );
6958     $self->debug("Doing localize") if $CPAN::DEBUG;
6959     $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
6960                                       $local_wanted)
6961         or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
6962
6963     if ($^O eq 'MacOS') {
6964         Mac::BuildTools::launch_file($local_file);
6965         return;
6966     }
6967
6968     my $fh_pager = FileHandle->new;
6969     local($SIG{PIPE}) = "IGNORE";
6970     my $pager = $CPAN::Config->{'pager'} || "cat";
6971     $fh_pager->open("|$pager")
6972         or die "Could not open pager $pager\: $!";
6973     my $fh_readme = FileHandle->new;
6974     $fh_readme->open($local_file)
6975         or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
6976     $CPAN::Frontend->myprint(qq{
6977 Displaying file
6978   $local_file
6979 with pager "$pager"
6980 });
6981     $fh_pager->print(<$fh_readme>);
6982     $fh_pager->close;
6983 }
6984
6985 #-> sub CPAN::Distribution::verifyCHECKSUM ;
6986 sub verifyCHECKSUM {
6987     my($self) = @_;
6988   EXCUSE: {
6989         my @e;
6990         $self->{CHECKSUM_STATUS} ||= "";
6991         $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
6992         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
6993     }
6994     my($lc_want,$lc_file,@local,$basename);
6995     @local = split(/\//,$self->id);
6996     pop @local;
6997     push @local, "CHECKSUMS";
6998     $lc_want =
6999         File::Spec->catfile($CPAN::Config->{keep_source_where},
7000                             "authors", "id", @local);
7001     local($") = "/";
7002     if (my $size = -s $lc_want) {
7003         $self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG;
7004         if ($self->CHECKSUM_check_file($lc_want,1)) {
7005             return $self->{CHECKSUM_STATUS} = "OK";
7006         }
7007     }
7008     $lc_file = CPAN::FTP->localize("authors/id/@local",
7009                                    $lc_want,1);
7010     unless ($lc_file) {
7011         $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
7012         $local[-1] .= ".gz";
7013         $lc_file = CPAN::FTP->localize("authors/id/@local",
7014                                        "$lc_want.gz",1);
7015         if ($lc_file) {
7016             $lc_file =~ s/\.gz(?!\n)\Z//;
7017             eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
7018         } else {
7019             return;
7020         }
7021     }
7022     if ($self->CHECKSUM_check_file($lc_file)) {
7023         return $self->{CHECKSUM_STATUS} = "OK";
7024     }
7025 }
7026
7027 #-> sub CPAN::Distribution::SIG_check_file ;
7028 sub SIG_check_file {
7029     my($self,$chk_file) = @_;
7030     my $rv = eval { Module::Signature::_verify($chk_file) };
7031
7032     if ($rv == Module::Signature::SIGNATURE_OK()) {
7033         $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
7034         return $self->{SIG_STATUS} = "OK";
7035     } else {
7036         $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
7037                                  qq{distribution file. }.
7038                                  qq{Please investigate.\n\n}.
7039                                  $self->as_string,
7040                                  $CPAN::META->instance(
7041                                                        'CPAN::Author',
7042                                                        $self->cpan_userid
7043                                                       )->as_string);
7044
7045         my $wrap = qq{I\'d recommend removing $chk_file. Its signature
7046 is invalid. Maybe you have configured your 'urllist' with
7047 a bad URL. Please check this array with 'o conf urllist', and
7048 retry.};
7049
7050         $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
7051     }
7052 }
7053
7054 #-> sub CPAN::Distribution::CHECKSUM_check_file ;
7055
7056 # sloppy is 1 when we have an old checksums file that maybe is good
7057 # enough
7058
7059 sub CHECKSUM_check_file {
7060     my($self,$chk_file,$sloppy) = @_;
7061     my($cksum,$file,$basename);
7062
7063     $sloppy ||= 0;
7064     $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG;
7065     my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
7066                                                       q{check_sigs});
7067     if ($check_sigs) {
7068         if ($CPAN::META->has_inst("Module::Signature")) {
7069             $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
7070             $self->SIG_check_file($chk_file);
7071         } else {
7072             $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
7073         }
7074     }
7075
7076     $file = $self->{localfile};
7077     $basename = File::Basename::basename($file);
7078     my $fh = FileHandle->new;
7079     if (open $fh, $chk_file) {
7080         local($/);
7081         my $eval = <$fh>;
7082         $eval =~ s/\015?\012/\n/g;
7083         close $fh;
7084         my($comp) = Safe->new();
7085         $cksum = $comp->reval($eval);
7086         if ($@) {
7087             rename $chk_file, "$chk_file.bad";
7088             Carp::confess($@) if $@;
7089         }
7090     } else {
7091         Carp::carp "Could not open $chk_file for reading";
7092     }
7093
7094     if (! ref $cksum or ref $cksum ne "HASH") {
7095         $CPAN::Frontend->mywarn(qq{
7096 Warning: checksum file '$chk_file' broken.
7097
7098 When trying to read that file I expected to get a hash reference
7099 for further processing, but got garbage instead.
7100 });
7101         my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
7102         $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
7103         $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken";
7104         return;
7105     } elsif (exists $cksum->{$basename}{sha256}) {
7106         $self->debug("Found checksum for $basename:" .
7107                      "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
7108
7109         open($fh, $file);
7110         binmode $fh;
7111         my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
7112         $fh->close;
7113         $fh = CPAN::Tarzip->TIEHANDLE($file);
7114
7115         unless ($eq) {
7116             my $dg = Digest::SHA->new(256);
7117             my($data,$ref);
7118             $ref = \$data;
7119             while ($fh->READ($ref, 4096) > 0) {
7120                 $dg->add($data);
7121             }
7122             my $hexdigest = $dg->hexdigest;
7123             $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
7124         }
7125
7126         if ($eq) {
7127             $CPAN::Frontend->myprint("Checksum for $file ok\n");
7128             return $self->{CHECKSUM_STATUS} = "OK";
7129         } else {
7130             $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
7131                                      qq{distribution file. }.
7132                                      qq{Please investigate.\n\n}.
7133                                      $self->as_string,
7134                                      $CPAN::META->instance(
7135                                                            'CPAN::Author',
7136                                                            $self->cpan_userid
7137                                                           )->as_string);
7138
7139             my $wrap = qq{I\'d recommend removing $file. Its
7140 checksum is incorrect. Maybe you have configured your 'urllist' with
7141 a bad URL. Please check this array with 'o conf urllist', and
7142 retry.};
7143
7144             $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
7145
7146             # former versions just returned here but this seems a
7147             # serious threat that deserves a die
7148
7149             # $CPAN::Frontend->myprint("\n\n");
7150             # sleep 3;
7151             # return;
7152         }
7153         # close $fh if fileno($fh);
7154     } else {
7155         return if $sloppy;
7156         unless ($self->{CHECKSUM_STATUS}) {
7157             $CPAN::Frontend->mywarn(qq{
7158 Warning: No checksum for $basename in $chk_file.
7159
7160 The cause for this may be that the file is very new and the checksum
7161 has not yet been calculated, but it may also be that something is
7162 going awry right now.
7163 });
7164             my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes");
7165             $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
7166         }
7167         $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file";
7168         return;
7169     }
7170 }
7171
7172 #-> sub CPAN::Distribution::eq_CHECKSUM ;
7173 sub eq_CHECKSUM {
7174     my($self,$fh,$expect) = @_;
7175     if ($CPAN::META->has_inst("Digest::SHA")) {
7176         my $dg = Digest::SHA->new(256);
7177         my($data);
7178         while (read($fh, $data, 4096)) {
7179             $dg->add($data);
7180         }
7181         my $hexdigest = $dg->hexdigest;
7182         # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
7183         return $hexdigest eq $expect;
7184     }
7185     return 1;
7186 }
7187
7188 #-> sub CPAN::Distribution::force ;
7189
7190 # Both CPAN::Modules and CPAN::Distributions know if "force" is in
7191 # effect by autoinspection, not by inspecting a global variable. One
7192 # of the reason why this was chosen to work that way was the treatment
7193 # of dependencies. They should not automatically inherit the force
7194 # status. But this has the downside that ^C and die() will return to
7195 # the prompt but will not be able to reset the force_update
7196 # attributes. We try to correct for it currently in the read_metadata
7197 # routine, and immediately before we check for a Signal. I hope this
7198 # works out in one of v1.57_53ff
7199
7200 # "Force get forgets previous error conditions"
7201
7202 #-> sub CPAN::Distribution::fforce ;
7203 sub fforce {
7204   my($self, $method) = @_;
7205   $self->force($method,1);
7206 }
7207
7208 #-> sub CPAN::Distribution::force ;
7209 sub force {
7210   my($self, $method,$fforce) = @_;
7211   my %phase_map = (
7212                    get => [
7213                            "unwrapped",
7214                            "build_dir",
7215                            "archived",
7216                            "localfile",
7217                            "CHECKSUM_STATUS",
7218                            "signature_verify",
7219                            "prefs",
7220                            "prefs_file",
7221                            "prefs_file_doc",
7222                           ],
7223                    make => [
7224                             "writemakefile",
7225                             "make",
7226                             "modulebuild",
7227                             "prereq_pm",
7228                             "prereq_pm_detected",
7229                            ],
7230                    test => [
7231                             "badtestcnt",
7232                             "make_test",
7233                            ],
7234                    install => [
7235                                "install",
7236                               ],
7237                    unknown => [
7238                                "reqtype",
7239                                "yaml_content",
7240                               ],
7241                   );
7242   my $methodmatch = 0;
7243   my $ldebug = 0;
7244  PHASE: for my $phase (qw(unknown get make test install)) { # order matters
7245       $methodmatch = 1 if $fforce || $phase eq $method;
7246       next unless $methodmatch;
7247     ATTRIBUTE: for my $att (@{$phase_map{$phase}}) {
7248           if ($phase eq "get") {
7249               if (substr($self->id,-1,1) eq "."
7250                   && $att =~ /(unwrapped|build_dir|archived)/ ) {
7251                   # cannot be undone for local distros
7252                   next ATTRIBUTE;
7253               }
7254               if ($att eq "build_dir"
7255                   && $self->{build_dir}
7256                   && $CPAN::META->{is_tested}
7257                  ) {
7258                   delete $CPAN::META->{is_tested}{$self->{build_dir}};
7259               }
7260           } elsif ($phase eq "test") {
7261               if ($att eq "make_test"
7262                   && $self->{make_test}
7263                   && $self->{make_test}{COMMANDID}
7264                   && $self->{make_test}{COMMANDID} == $CPAN::CurrentCommandId
7265                  ) {
7266                   # endless loop too likely
7267                   next ATTRIBUTE;
7268               }
7269           }
7270           delete $self->{$att};
7271           if ($ldebug || $CPAN::DEBUG) {
7272               # local $CPAN::DEBUG = 16; # Distribution
7273               CPAN->debug(sprintf "id[%s]phase[%s]att[%s]", $self->id, $phase, $att);
7274           }
7275       }
7276   }
7277   if ($method && $method =~ /make|test|install/) {
7278     $self->{force_update} = 1; # name should probably have been force_install
7279   }
7280 }
7281
7282 #-> sub CPAN::Distribution::notest ;
7283 sub notest {
7284   my($self, $method) = @_;
7285   # $CPAN::Frontend->mywarn("XDEBUG: set notest for $self $method");
7286   $self->{"notest"}++; # name should probably have been force_install
7287 }
7288
7289 #-> sub CPAN::Distribution::unnotest ;
7290 sub unnotest {
7291   my($self) = @_;
7292   # warn "XDEBUG: deleting notest";
7293   delete $self->{notest};
7294 }
7295
7296 #-> sub CPAN::Distribution::unforce ;
7297 sub unforce {
7298   my($self) = @_;
7299   delete $self->{force_update};
7300 }
7301
7302 #-> sub CPAN::Distribution::isa_perl ;
7303 sub isa_perl {
7304   my($self) = @_;
7305   my $file = File::Basename::basename($self->id);
7306   if ($file =~ m{ ^ perl
7307                   -?
7308                   (5)
7309                   ([._-])
7310                   (
7311                    \d{3}(_[0-4][0-9])?
7312                    |
7313                    \d+\.\d+
7314                   )
7315                   \.tar[._-](?:gz|bz2)
7316                   (?!\n)\Z
7317                 }xs) {
7318     return "$1.$3";
7319   } elsif ($self->cpan_comment
7320            &&
7321            $self->cpan_comment =~ /isa_perl\(.+?\)/) {
7322     return $1;
7323   }
7324 }
7325
7326
7327 #-> sub CPAN::Distribution::perl ;
7328 sub perl {
7329     my ($self) = @_;
7330     if (! $self) {
7331         use Carp qw(carp);
7332         carp __PACKAGE__ . "::perl was called without parameters.";
7333     }
7334     return CPAN::HandleConfig->safe_quote($CPAN::Perl);
7335 }
7336
7337
7338 #-> sub CPAN::Distribution::make ;
7339 sub make {
7340     my($self) = @_;
7341     if (my $goto = $self->prefs->{goto}) {
7342         return $self->goto($goto);
7343     }
7344     my $make = $self->{modulebuild} ? "Build" : "make";
7345     # Emergency brake if they said install Pippi and get newest perl
7346     if ($self->isa_perl) {
7347         if (
7348             $self->called_for ne $self->id &&
7349             ! $self->{force_update}
7350         ) {
7351             # if we die here, we break bundles
7352             $CPAN::Frontend
7353                 ->mywarn(sprintf(
7354                             qq{The most recent version "%s" of the module "%s"
7355 is part of the perl-%s distribution. To install that, you need to run
7356   force install %s   --or--
7357   install %s
7358 },
7359                              $CPAN::META->instance(
7360                                                    'CPAN::Module',
7361                                                    $self->called_for
7362                                                   )->cpan_version,
7363                              $self->called_for,
7364                              $self->isa_perl,
7365                              $self->called_for,
7366                              $self->id,
7367                             ));
7368             $self->{make} = CPAN::Distrostatus->new("NO isa perl");
7369             $CPAN::Frontend->mysleep(1);
7370             return;
7371         }
7372     }
7373     $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
7374     $self->get;
7375     if ($self->{configure_requires_later}) {
7376         return;
7377     }
7378     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
7379                            ? $ENV{PERL5LIB}
7380                            : ($ENV{PERLLIB} || "");
7381     $CPAN::META->set_perl5lib;
7382     local $ENV{MAKEFLAGS}; # protect us from outer make calls
7383
7384     if ($CPAN::Signal) {
7385         delete $self->{force_update};
7386         return;
7387     }
7388
7389     my $builddir;
7390   EXCUSE: {
7391         my @e;
7392         if (!$self->{archived} || $self->{archived} eq "NO") {
7393             push @e, "Is neither a tar nor a zip archive.";
7394         }
7395
7396         if (!$self->{unwrapped}
7397             || (
7398                 UNIVERSAL::can($self->{unwrapped},"failed") ?
7399                 $self->{unwrapped}->failed :
7400                 $self->{unwrapped} =~ /^NO/
7401                )) {
7402             push @e, "Had problems unarchiving. Please build manually";
7403         }
7404
7405         unless ($self->{force_update}) {
7406             exists $self->{signature_verify} and
7407                 (
7408                  UNIVERSAL::can($self->{signature_verify},"failed") ?
7409                  $self->{signature_verify}->failed :
7410                  $self->{signature_verify} =~ /^NO/
7411                 )
7412                 and push @e, "Did not pass the signature test.";
7413         }
7414
7415         if (exists $self->{writemakefile} &&
7416             (
7417              UNIVERSAL::can($self->{writemakefile},"failed") ?
7418              $self->{writemakefile}->failed :
7419              $self->{writemakefile} =~ /^NO/
7420             )) {
7421             # XXX maybe a retry would be in order?
7422             my $err = UNIVERSAL::can($self->{writemakefile},"text") ?
7423                 $self->{writemakefile}->text :
7424                     $self->{writemakefile};
7425             $err =~ s/^NO\s*//;
7426             $err ||= "Had some problem writing Makefile";
7427             $err .= ", won't make";
7428             push @e, $err;
7429         }
7430
7431         if (defined $self->{make}) {
7432             if (UNIVERSAL::can($self->{make},"failed") ?
7433                 $self->{make}->failed :
7434                 $self->{make} =~ /^NO/) {
7435                 if ($self->{force_update}) {
7436                     # Trying an already failed 'make' (unless somebody else blocks)
7437                 } else {
7438                     # introduced for turning recursion detection into a distrostatus
7439                     my $error = length $self->{make}>3
7440                         ? substr($self->{make},3) : "Unknown error";
7441                     $CPAN::Frontend->mywarn("Could not make: $error\n");
7442                     $self->store_persistent_state;
7443                     return;
7444                 }
7445             } else {
7446                 push @e, "Has already been made";
7447             }
7448         }
7449
7450         my $later = $self->{later} || $self->{configure_requires_later};
7451         if ($later) { # see also undelay
7452             if ($later) {
7453                 push @e, $later;
7454             }
7455         }
7456
7457         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
7458         $builddir = $self->dir or
7459             $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
7460         unless (chdir $builddir) {
7461             push @e, "Couldn't chdir to '$builddir': $!";
7462         }
7463         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
7464     }
7465     if ($CPAN::Signal) {
7466         delete $self->{force_update};
7467         return;
7468     }
7469     $CPAN::Frontend->myprint("\n  CPAN.pm: Going to build ".$self->id."\n\n");
7470     $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
7471
7472     if ($^O eq 'MacOS') {
7473         Mac::BuildTools::make($self);
7474         return;
7475     }
7476
7477     my %env;
7478     while (my($k,$v) = each %ENV) {
7479         next unless defined $v;
7480         $env{$k} = $v;
7481     }
7482     local %ENV = %env;
7483     my $system;
7484     if (my $commandline = $self->prefs->{pl}{commandline}) {
7485         $system = $commandline;
7486         $ENV{PERL} = $^X;
7487     } elsif ($self->{'configure'}) {
7488         $system = $self->{'configure'};
7489     } elsif ($self->{modulebuild}) {
7490         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
7491         $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}";
7492     } else {
7493         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
7494         my $switch = "";
7495 # This needs a handler that can be turned on or off:
7496 #        $switch = "-MExtUtils::MakeMaker ".
7497 #            "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
7498 #            if $] > 5.00310;
7499         my $makepl_arg = $self->make_x_arg("pl");
7500         $ENV{PERL5_CPAN_IS_EXECUTING} = File::Spec->catfile($self->{build_dir},
7501                                                             "Makefile.PL");
7502         $system = sprintf("%s%s Makefile.PL%s",
7503                           $perl,
7504                           $switch ? " $switch" : "",
7505                           $makepl_arg ? " $makepl_arg" : "",
7506                          );
7507     }
7508     if (my $env = $self->prefs->{pl}{env}) {
7509         for my $e (keys %$env) {
7510             $ENV{$e} = $env->{$e};
7511         }
7512     }
7513     if (exists $self->{writemakefile}) {
7514     } else {
7515         local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
7516         my($ret,$pid,$output);
7517         $@ = "";
7518         my $go_via_alarm;
7519         if ($CPAN::Config->{inactivity_timeout}) {
7520             require Config;
7521             if ($Config::Config{d_alarm}
7522                 &&
7523                 $Config::Config{d_alarm} eq "define"
7524                ) {
7525                 $go_via_alarm++
7526             } else {
7527                 $CPAN::Frontend->mywarn("Warning: you have configured the config ".
7528                                         "variable 'inactivity_timeout' to ".
7529                                         "'$CPAN::Config->{inactivity_timeout}'. But ".
7530                                         "on this machine the system call 'alarm' ".
7531                                         "isn't available. This means that we cannot ".
7532                                         "provide the feature of intercepting long ".
7533                                         "waiting code and will turn this feature off.\n"
7534                                        );
7535                 $CPAN::Config->{inactivity_timeout} = 0;
7536             }
7537         }
7538         if ($go_via_alarm) {
7539             if ( $self->_should_report('pl') ) {
7540                 ($output, $ret) = CPAN::Reporter::record_command(
7541                     $system,
7542                     $CPAN::Config->{inactivity_timeout},
7543                 );
7544                 CPAN::Reporter::grade_PL( $self, $system, $output, $ret );
7545             }
7546             else {
7547                 eval {
7548                     alarm $CPAN::Config->{inactivity_timeout};
7549                     local $SIG{CHLD}; # = sub { wait };
7550                     if (defined($pid = fork)) {
7551                         if ($pid) { #parent
7552                             # wait;
7553                             waitpid $pid, 0;
7554                         } else {    #child
7555                             # note, this exec isn't necessary if
7556                             # inactivity_timeout is 0. On the Mac I'd
7557                             # suggest, we set it always to 0.
7558                             exec $system;
7559                         }
7560                     } else {
7561                         $CPAN::Frontend->myprint("Cannot fork: $!");
7562                         return;
7563                     }
7564                 };
7565                 alarm 0;
7566                 if ($@) {
7567                     kill 9, $pid;
7568                     waitpid $pid, 0;
7569                     my $err = "$@";
7570                     $CPAN::Frontend->myprint($err);
7571                     $self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
7572                     $@ = "";
7573                     $self->store_persistent_state;
7574                     return $self->goodbye("$system -- TIMED OUT");
7575                 }
7576             }
7577         } else {
7578             if (my $expect_model = $self->_prefs_with_expect("pl")) {
7579                 # XXX probably want to check _should_report here and warn
7580                 # about not being able to use CPAN::Reporter with expect
7581                 $ret = $self->_run_via_expect($system,$expect_model);
7582                 if (! defined $ret
7583                     && $self->{writemakefile}
7584                     && $self->{writemakefile}->failed) {
7585                     # timeout
7586                     return;
7587                 }
7588             }
7589             elsif ( $self->_should_report('pl') ) {
7590                 ($output, $ret) = CPAN::Reporter::record_command($system);
7591                 CPAN::Reporter::grade_PL( $self, $system, $output, $ret );
7592             }
7593             else {
7594                 $ret = system($system);
7595             }
7596             if ($ret != 0) {
7597                 $self->{writemakefile} = CPAN::Distrostatus
7598                     ->new("NO '$system' returned status $ret");
7599                 $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
7600                 $self->store_persistent_state;
7601                 return $self->goodbye("$system -- NOT OK");
7602             }
7603         }
7604         if (-f "Makefile" || -f "Build") {
7605             $self->{writemakefile} = CPAN::Distrostatus->new("YES");
7606             delete $self->{make_clean}; # if cleaned before, enable next
7607         } else {
7608             my $makefile = $self->{modulebuild} ? "Build" : "Makefile";
7609             $self->{writemakefile} = CPAN::Distrostatus
7610                 ->new(qq{NO -- No $makefile created});
7611             $self->store_persistent_state;
7612             return $self->goodbye("$system -- NO $makefile created");
7613         }
7614     }
7615     if ($CPAN::Signal) {
7616         delete $self->{force_update};
7617         return;
7618     }
7619     if (my @prereq = $self->unsat_prereq("later")) {
7620         if ($prereq[0][0] eq "perl") {
7621             my $need = "requires perl '$prereq[0][1]'";
7622             my $id = $self->pretty_id;
7623             $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
7624             $self->{make} = CPAN::Distrostatus->new("NO $need");
7625             $self->store_persistent_state;
7626             return $self->goodbye("[prereq] -- NOT OK");
7627         } else {
7628             my $follow = eval { $self->follow_prereqs("later",@prereq); };
7629             if (0) {
7630             } elsif ($follow) {
7631                 # signal success to the queuerunner
7632                 return 1;
7633             } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
7634                 $CPAN::Frontend->mywarn($@);
7635                 return $self->goodbye("[depend] -- NOT OK");
7636             }
7637         }
7638     }
7639     if ($CPAN::Signal) {
7640         delete $self->{force_update};
7641         return;
7642     }
7643     if (my $commandline = $self->prefs->{make}{commandline}) {
7644         $system = $commandline;
7645         $ENV{PERL} = CPAN::find_perl;
7646     } else {
7647         if ($self->{modulebuild}) {
7648             unless (-f "Build") {
7649                 my $cwd = CPAN::anycwd();
7650                 $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
7651                                         " in cwd[$cwd]. Danger, Will Robinson!\n");
7652                 $CPAN::Frontend->mysleep(5);
7653             }
7654             $system = join " ", $self->_build_command(), $CPAN::Config->{mbuild_arg};
7655         } else {
7656             $system = join " ", $self->_make_command(),  $CPAN::Config->{make_arg};
7657         }
7658         $system =~ s/\s+$//;
7659         my $make_arg = $self->make_x_arg("make");
7660         $system = sprintf("%s%s",
7661                           $system,
7662                           $make_arg ? " $make_arg" : "",
7663                          );
7664     }
7665     if (my $env = $self->prefs->{make}{env}) { # overriding the local
7666                                                # ENV of PL, not the
7667                                                # outer ENV, but
7668                                                # unlikely to be a risk
7669         for my $e (keys %$env) {
7670             $ENV{$e} = $env->{$e};
7671         }
7672     }
7673     my $expect_model = $self->_prefs_with_expect("make");
7674     my $want_expect = 0;
7675     if ( $expect_model && @{$expect_model->{talk}} ) {
7676         my $can_expect = $CPAN::META->has_inst("Expect");
7677         if ($can_expect) {
7678             $want_expect = 1;
7679         } else {
7680             $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
7681                                     "system()\n");
7682         }
7683     }
7684     my $system_ok;
7685     if ($want_expect) {
7686         # XXX probably want to check _should_report here and
7687         # warn about not being able to use CPAN::Reporter with expect
7688         $system_ok = $self->_run_via_expect($system,$expect_model) == 0;
7689     }
7690     elsif ( $self->_should_report('make') ) {
7691         my ($output, $ret) = CPAN::Reporter::record_command($system);
7692         CPAN::Reporter::grade_make( $self, $system, $output, $ret );
7693         $system_ok = ! $ret;
7694     }
7695     else {
7696         $system_ok = system($system) == 0;
7697     }
7698     $self->introduce_myself;
7699     if ( $system_ok ) {
7700         $CPAN::Frontend->myprint("  $system -- OK\n");
7701         $self->{make} = CPAN::Distrostatus->new("YES");
7702     } else {
7703         $self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
7704         $self->{make} = CPAN::Distrostatus->new("NO");
7705         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
7706     }
7707     $self->store_persistent_state;
7708 }
7709
7710 # CPAN::Distribution::goodbye ;
7711 sub goodbye {
7712     my($self,$goodbye) = @_;
7713     my $id = $self->pretty_id;
7714     $CPAN::Frontend->mywarn("  $id\n  $goodbye\n");
7715     return;
7716 }
7717
7718 # CPAN::Distribution::_run_via_expect ;
7719 sub _run_via_expect {
7720     my($self,$system,$expect_model) = @_;
7721     CPAN->debug("system[$system]expect_model[$expect_model]") if $CPAN::DEBUG;
7722     if ($CPAN::META->has_inst("Expect")) {
7723         my $expo = Expect->new;  # expo Expect object;
7724         $expo->spawn($system);
7725         $expect_model->{mode} ||= "deterministic";
7726         if ($expect_model->{mode} eq "deterministic") {
7727             return $self->_run_via_expect_deterministic($expo,$expect_model);
7728         } elsif ($expect_model->{mode} eq "anyorder") {
7729             return $self->_run_via_expect_anyorder($expo,$expect_model);
7730         } else {
7731             die "Panic: Illegal expect mode: $expect_model->{mode}";
7732         }
7733     } else {
7734         $CPAN::Frontend->mywarn("Expect not installed, falling back to system()\n");
7735         return system($system);
7736     }
7737 }
7738
7739 sub _run_via_expect_anyorder {
7740     my($self,$expo,$expect_model) = @_;
7741     my $timeout = $expect_model->{timeout} || 5;
7742     my $reuse = $expect_model->{reuse};
7743     my @expectacopy = @{$expect_model->{talk}}; # we trash it!
7744     my $but = "";
7745   EXPECT: while () {
7746         my($eof,$ran_into_timeout);
7747         my @match = $expo->expect($timeout,
7748                                   [ eof => sub {
7749                                         $eof++;
7750                                     } ],
7751                                   [ timeout => sub {
7752                                         $ran_into_timeout++;
7753                                     } ],
7754                                   -re => eval"qr{.}",
7755                                  );
7756         if ($match[2]) {
7757             $but .= $match[2];
7758         }
7759         $but .= $expo->clear_accum;
7760         if ($eof) {
7761             $expo->soft_close;
7762             return $expo->exitstatus();
7763         } elsif ($ran_into_timeout) {
7764             # warn "DEBUG: they are asking a question, but[$but]";
7765             for (my $i = 0; $i <= $#expectacopy; $i+=2) {
7766                 my($next,$send) = @expectacopy[$i,$i+1];
7767                 my $regex = eval "qr{$next}";
7768                 # warn "DEBUG: will compare with regex[$regex].";
7769                 if ($but =~ /$regex/) {
7770                     # warn "DEBUG: will send send[$send]";
7771                     $expo->send($send);
7772                     # never allow reusing an QA pair unless they told us
7773                     splice @expectacopy, $i, 2 unless $reuse;
7774                     next EXPECT;
7775                 }
7776             }
7777             my $why = "could not answer a question during the dialog";
7778             $CPAN::Frontend->mywarn("Failing: $why\n");
7779             $self->{writemakefile} =
7780                 CPAN::Distrostatus->new("NO $why");
7781             return;
7782         }
7783     }
7784 }
7785
7786 sub _run_via_expect_deterministic {
7787     my($self,$expo,$expect_model) = @_;
7788     my $ran_into_timeout;
7789     my $timeout = $expect_model->{timeout} || 15; # currently unsettable
7790     my $expecta = $expect_model->{talk};
7791   EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) {
7792         my($re,$send) = @$expecta[$i,$i+1];
7793         CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG;
7794         my $regex = eval "qr{$re}";
7795         $expo->expect($timeout,
7796                       [ eof => sub {
7797                             my $but = $expo->clear_accum;
7798                             $CPAN::Frontend->mywarn("EOF (maybe harmless)
7799 expected[$regex]\nbut[$but]\n\n");
7800                             last EXPECT;
7801                         } ],
7802                       [ timeout => sub {
7803                             my $but = $expo->clear_accum;
7804                             $CPAN::Frontend->mywarn("TIMEOUT
7805 expected[$regex]\nbut[$but]\n\n");
7806                             $ran_into_timeout++;
7807                         } ],
7808                       -re => $regex);
7809         if ($ran_into_timeout) {
7810             # note that the caller expects 0 for success
7811             $self->{writemakefile} =
7812                 CPAN::Distrostatus->new("NO timeout during expect dialog");
7813             return;
7814         }
7815         $expo->send($send);
7816     }
7817     $expo->soft_close;
7818     return $expo->exitstatus();
7819 }
7820
7821 #-> CPAN::Distribution::_validate_distropref
7822 sub _validate_distropref {
7823     my($self,@args) = @_;
7824     if (
7825         $CPAN::META->has_inst("CPAN::Kwalify")
7826         &&
7827         $CPAN::META->has_inst("Kwalify")
7828        ) {
7829         eval {CPAN::Kwalify::_validate("distroprefs",@args);};
7830         if ($@) {
7831             $CPAN::Frontend->mywarn($@);
7832         }
7833     } else {
7834         CPAN->debug("not validating '@args'") if $CPAN::DEBUG;
7835     }
7836 }
7837
7838 #-> CPAN::Distribution::_find_prefs
7839 sub _find_prefs {
7840     my($self) = @_;
7841     my $distroid = $self->pretty_id;
7842     #CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG;
7843     my $prefs_dir = $CPAN::Config->{prefs_dir};
7844     return if $prefs_dir =~ /^\s*$/;
7845     eval { File::Path::mkpath($prefs_dir); };
7846     if ($@) {
7847         $CPAN::Frontend->mydie("Cannot create directory $prefs_dir");
7848     }
7849     my $yaml_module = CPAN::_yaml_module;
7850     my @extensions;
7851     if ($CPAN::META->has_inst($yaml_module)) {
7852         push @extensions, "yml";
7853     } else {
7854         my @fallbacks;
7855         if ($CPAN::META->has_inst("Data::Dumper")) {
7856             push @extensions, "dd";
7857             push @fallbacks, "Data::Dumper";
7858         }
7859         if ($CPAN::META->has_inst("Storable")) {
7860             push @extensions, "st";
7861             push @fallbacks, "Storable";
7862         }
7863         if (@fallbacks) {
7864             local $" = " and ";
7865             unless ($self->{have_complained_about_missing_yaml}++) {
7866                 $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back ".
7867                                         "to @fallbacks to read prefs '$prefs_dir'\n");
7868             }
7869         } else {
7870             unless ($self->{have_complained_about_missing_yaml}++) {
7871                 $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot ".
7872                                         "read prefs '$prefs_dir'\n");
7873             }
7874         }
7875     }
7876     if (@extensions) {
7877         my $dh = DirHandle->new($prefs_dir)
7878             or die Carp::croak("Couldn't open '$prefs_dir': $!");
7879       DIRENT: for (sort $dh->read) {
7880             next if $_ eq "." || $_ eq "..";
7881             my $exte = join "|", @extensions;
7882             next unless /\.($exte)$/;
7883             my $thisexte = $1;
7884             my $abs = File::Spec->catfile($prefs_dir, $_);
7885             if (-f $abs) {
7886                 #CPAN->debug(sprintf "abs[%s]", $abs) if $CPAN::DEBUG;
7887                 my @distropref;
7888                 if ($thisexte eq "yml") {
7889                     # need no eval because if we have no YAML we do not try to read *.yml
7890                     #CPAN->debug(sprintf "before yaml load abs[%s]", $abs) if $CPAN::DEBUG;
7891                     @distropref = @{CPAN->_yaml_loadfile($abs)};
7892                     #CPAN->debug(sprintf "after yaml load abs[%s]", $abs) if $CPAN::DEBUG;
7893                 } elsif ($thisexte eq "dd") {
7894                     package CPAN::Eval;
7895                     no strict;
7896                     open FH, "<$abs" or $CPAN::Frontend->mydie("Could not open '$abs': $!");
7897                     local $/;
7898                     my $eval = <FH>;
7899                     close FH;
7900                     eval $eval;
7901                     if ($@) {
7902                         $CPAN::Frontend->mydie("Error in distroprefs file $_\: $@");
7903                     }
7904                     my $i = 1;
7905                     while (${"VAR".$i}) {
7906                         push @distropref, ${"VAR".$i};
7907                         $i++;
7908                     }
7909                 } elsif ($thisexte eq "st") {
7910                     # eval because Storable is never forward compatible
7911                     eval { @distropref = @{scalar Storable::retrieve($abs)}; };
7912                     if ($@) {
7913                         $CPAN::Frontend->mywarn("Error reading distroprefs file ".
7914                                                 "$_, skipping\: $@");
7915                         $CPAN::Frontend->mysleep(4);
7916                         next DIRENT;
7917                     }
7918                 }
7919                 # $DB::single=1;
7920                 #CPAN->debug(sprintf "#distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
7921               ELEMENT: for my $y (0..$#distropref) {
7922                     my $distropref = $distropref[$y];
7923                     $self->_validate_distropref($distropref,$abs,$y);
7924                     my $match = $distropref->{match};
7925                     unless ($match) {
7926                         #CPAN->debug("no 'match' in abs[$abs], skipping") if $CPAN::DEBUG;
7927                         next ELEMENT;
7928                     }
7929                     my $ok = 1;
7930                     # do not take the order of C<keys %$match> because
7931                     # "module" is by far the slowest
7932                     my $saw_valid_subkeys = 0;
7933                     for my $sub_attribute (qw(distribution perl perlconfig module)) {
7934                         next unless exists $match->{$sub_attribute};
7935                         $saw_valid_subkeys++;
7936                         my $qr = eval "qr{$distropref->{match}{$sub_attribute}}";
7937                         if ($sub_attribute eq "module") {
7938                             my $okm = 0;
7939                             #CPAN->debug(sprintf "distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
7940                             my @modules = $self->containsmods;
7941                             #CPAN->debug(sprintf "modules[%s]", join(",",@modules)) if $CPAN::DEBUG;
7942                           MODULE: for my $module (@modules) {
7943                                 $okm ||= $module =~ /$qr/;
7944                                 last MODULE if $okm;
7945                             }
7946                             $ok &&= $okm;
7947                         } elsif ($sub_attribute eq "distribution") {
7948                             my $okd = $distroid =~ /$qr/;
7949                             $ok &&= $okd;
7950                         } elsif ($sub_attribute eq "perl") {
7951                             my $okp = CPAN::find_perl =~ /$qr/;
7952                             $ok &&= $okp;
7953                         } elsif ($sub_attribute eq "perlconfig") {
7954                             for my $perlconfigkey (keys %{$match->{perlconfig}}) {
7955                                 my $perlconfigval = $match->{perlconfig}->{$perlconfigkey};
7956                                 # XXX should probably warn if Config does not exist
7957                                 my $okpc = $Config::Config{$perlconfigkey} =~ /$perlconfigval/;
7958                                 $ok &&= $okpc;
7959                                 last if $ok == 0;
7960                             }
7961                         } else {
7962                             $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ".
7963                                                    "unknown sub_attribut '$sub_attribute'. ".
7964                                                    "Please ".
7965                                                    "remove, cannot continue.");
7966                         }
7967                         last if $ok == 0; # short circuit
7968                     }
7969                     unless ($saw_valid_subkeys) {
7970                         $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ".
7971                                                "missing match/* subattribute. ".
7972                                                "Please ".
7973                                                "remove, cannot continue.");
7974                     }
7975                     #CPAN->debug(sprintf "ok[%d]", $ok) if $CPAN::DEBUG;
7976                     if ($ok) {
7977                         return {
7978                                 prefs => $distropref,
7979                                 prefs_file => $abs,
7980                                 prefs_file_doc => $y,
7981                                };
7982                     }
7983
7984                 }
7985             }
7986         }
7987         $dh->close;
7988     }
7989     return;
7990 }
7991
7992 # CPAN::Distribution::prefs
7993 sub prefs {
7994     my($self) = @_;
7995     if (exists $self->{negative_prefs_cache}
7996         &&
7997         $self->{negative_prefs_cache} != $CPAN::CurrentCommandId
7998        ) {
7999         delete $self->{negative_prefs_cache};
8000         delete $self->{prefs};
8001     }
8002     if (exists $self->{prefs}) {
8003         return $self->{prefs}; # XXX comment out during debugging
8004     }
8005     if ($CPAN::Config->{prefs_dir}) {
8006         CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG;
8007         my $prefs = $self->_find_prefs();
8008         $prefs ||= ""; # avoid warning next line
8009         CPAN->debug("prefs[$prefs]") if $CPAN::DEBUG;
8010         if ($prefs) {
8011             for my $x (qw(prefs prefs_file prefs_file_doc)) {
8012                 $self->{$x} = $prefs->{$x};
8013             }
8014             my $bs = sprintf(
8015                              "%s[%s]",
8016                              File::Basename::basename($self->{prefs_file}),
8017                              $self->{prefs_file_doc},
8018                             );
8019             my $filler1 = "_" x 22;
8020             my $filler2 = int(66 - length($bs))/2;
8021             $filler2 = 0 if $filler2 < 0;
8022             $filler2 = " " x $filler2;
8023             $CPAN::Frontend->myprint("
8024 $filler1 D i s t r o P r e f s $filler1
8025 $filler2 $bs $filler2
8026 ");
8027             $CPAN::Frontend->mysleep(1);
8028             return $self->{prefs};
8029         }
8030     }
8031     $self->{negative_prefs_cache} = $CPAN::CurrentCommandId;
8032     return $self->{prefs} = +{};
8033 }
8034
8035 # CPAN::Distribution::make_x_arg
8036 sub make_x_arg {
8037     my($self, $whixh) = @_;
8038     my $make_x_arg;
8039     my $prefs = $self->prefs;
8040     if (
8041         $prefs
8042         && exists $prefs->{$whixh}
8043         && exists $prefs->{$whixh}{args}
8044         && $prefs->{$whixh}{args}
8045        ) {
8046         $make_x_arg = join(" ",
8047                            map {CPAN::HandleConfig
8048                                  ->safe_quote($_)} @{$prefs->{$whixh}{args}},
8049                           );
8050     }
8051     my $what = sprintf "make%s_arg", $whixh eq "make" ? "" : $whixh;
8052     $make_x_arg ||= $CPAN::Config->{$what};
8053     return $make_x_arg;
8054 }
8055
8056 # CPAN::Distribution::_make_command
8057 sub _make_command {
8058     my ($self) = @_;
8059     if ($self) {
8060         return
8061             CPAN::HandleConfig
8062                 ->safe_quote(
8063                              CPAN::HandleConfig->prefs_lookup($self,
8064                                                               q{make})
8065                              || $Config::Config{make}
8066                              || 'make'
8067                             );
8068     } else {
8069         # Old style call, without object. Deprecated
8070         Carp::confess("CPAN::_make_command() used as function. Don't Do That.");
8071         return
8072           safe_quote(undef,
8073                      CPAN::HandleConfig->prefs_lookup($self,q{make})
8074                      || $CPAN::Config->{make}
8075                      || $Config::Config{make}
8076                      || 'make');
8077     }
8078 }
8079
8080 #-> sub CPAN::Distribution::follow_prereqs ;
8081 sub follow_prereqs {
8082     my($self) = shift;
8083     my($slot) = shift;
8084     my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
8085     return unless @prereq_tuples;
8086     my @prereq = map { $_->[0] } @prereq_tuples;
8087     my $pretty_id = $self->pretty_id;
8088     my %map = (
8089                b => "build_requires",
8090                r => "requires",
8091                c => "commandline",
8092               );
8093     my($filler1,$filler2,$filler3,$filler4);
8094     # $DB::single=1;
8095     my $unsat = "Unsatisfied dependencies detected during";
8096     my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id);
8097     {
8098         my $r = int(($w - length($unsat))/2);
8099         my $l = $w - length($unsat) - $r;
8100         $filler1 = "-"x4 . " "x$l;
8101         $filler2 = " "x$r . "-"x4 . "\n";
8102     }
8103     {
8104         my $r = int(($w - length($pretty_id))/2);
8105         my $l = $w - length($pretty_id) - $r;
8106         $filler3 = "-"x4 . " "x$l;
8107         $filler4 = " "x$r . "-"x4 . "\n";
8108     }
8109     $CPAN::Frontend->
8110         myprint("$filler1 $unsat $filler2".
8111                 "$filler3 $pretty_id $filler4".
8112                 join("", map {"    $_->[0] \[$map{$_->[1]}]\n"} @prereq_tuples),
8113                );
8114     my $follow = 0;
8115     if ($CPAN::Config->{prerequisites_policy} eq "follow") {
8116         $follow = 1;
8117     } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
8118         my $answer = CPAN::Shell::colorable_makemaker_prompt(
8119 "Shall I follow them and prepend them to the queue
8120 of modules we are processing right now?", "yes");
8121         $follow = $answer =~ /^\s*y/i;
8122     } else {
8123         local($") = ", ";
8124         $CPAN::Frontend->
8125             myprint("  Ignoring dependencies on modules @prereq\n");
8126     }
8127     if ($follow) {
8128         my $id = $self->id;
8129         # color them as dirty
8130         for my $p (@prereq) {
8131             # warn "calling color_cmd_tmps(0,1)";
8132             my $any = CPAN::Shell->expandany($p);
8133             $self->{$slot . "_for"}{$any->id}++;
8134             if ($any) {
8135                 $any->color_cmd_tmps(0,2);
8136             } else {
8137                 $CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$p'\n");
8138                 $CPAN::Frontend->mysleep(2);
8139             }
8140         }
8141         # queue them and re-queue yourself
8142         CPAN::Queue->jumpqueue({qmod => $id, reqtype => $self->{reqtype}},
8143                                map {+{qmod=>$_->[0],reqtype=>$_->[1]}} reverse @prereq_tuples);
8144         $self->{$slot} = "Delayed until after prerequisites";
8145         return 1; # signal success to the queuerunner
8146     }
8147     return;
8148 }
8149
8150 #-> sub CPAN::Distribution::unsat_prereq ;
8151 # return ([Foo=>1],[Bar=>1.2]) for normal modules
8152 # return ([perl=>5.008]) if we need a newer perl than we are running under
8153 sub unsat_prereq {
8154     my($self,$slot) = @_;
8155     my(%merged,$prereq_pm);
8156     my $prefs_depends = $self->prefs->{depends}||{};
8157     if ($slot eq "configure_requires_later") {
8158         my $meta_yml = $self->parse_meta_yml();
8159         %merged = (%{$meta_yml->{configure_requires}||{}},
8160                    %{$prefs_depends->{configure_requires}||{}});
8161         $prereq_pm = {}; # configure_requires defined as "b"
8162     } elsif ($slot eq "later") {
8163         my $prereq_pm_0 = $self->prereq_pm || {};
8164         for my $reqtype (qw(requires build_requires)) {
8165             $prereq_pm->{$reqtype} = {%{$prereq_pm_0->{$reqtype}||{}}}; # copy to not pollute it
8166             for my $k (keys %{$prefs_depends->{$reqtype}||{}}) {
8167                 $prereq_pm->{$reqtype}{$k} = $prefs_depends->{$reqtype}{$k};
8168             }
8169         }
8170         %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}});
8171     } else {
8172         die "Panic: illegal slot '$slot'";
8173     }
8174     my(@need);
8175     my @merged = %merged;
8176     CPAN->debug("all merged_prereqs[@merged]") if $CPAN::DEBUG;
8177   NEED: while (my($need_module, $need_version) = each %merged) {
8178         my($available_version,$available_file,$nmo);
8179         if ($need_module eq "perl") {
8180             $available_version = $];
8181             $available_file = CPAN::find_perl;
8182         } else {
8183             $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
8184             next if $nmo->uptodate;
8185             $available_file = $nmo->available_file;
8186
8187             # if they have not specified a version, we accept any installed one
8188             if (defined $available_file
8189                 and ( # a few quick shortcurcuits
8190                      not defined $need_version
8191                      or $need_version eq '0'    # "==" would trigger warning when not numeric
8192                      or $need_version eq "undef"
8193                     )) {
8194                 next NEED;
8195             }
8196
8197             $available_version = $nmo->available_version;
8198         }
8199
8200         # We only want to install prereqs if either they're not installed
8201         # or if the installed version is too old. We cannot omit this
8202         # check, because if 'force' is in effect, nobody else will check.
8203         if (defined $available_file) {
8204             my(@all_requirements) = split /\s*,\s*/, $need_version;
8205             local($^W) = 0;
8206             my $ok = 0;
8207           RQ: for my $rq (@all_requirements) {
8208                 if ($rq =~ s|>=\s*||) {
8209                 } elsif ($rq =~ s|>\s*||) {
8210                     # 2005-12: one user
8211                     if (CPAN::Version->vgt($available_version,$rq)) {
8212                         $ok++;
8213                     }
8214                     next RQ;
8215                 } elsif ($rq =~ s|!=\s*||) {
8216                     # 2005-12: no user
8217                     if (CPAN::Version->vcmp($available_version,$rq)) {
8218                         $ok++;
8219                         next RQ;
8220                     } else {
8221                         last RQ;
8222                     }
8223                 } elsif ($rq =~ m|<=?\s*|) {
8224                     # 2005-12: no user
8225                     $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n");
8226                     $ok++;
8227                     next RQ;
8228                 }
8229                 if (! CPAN::Version->vgt($rq, $available_version)) {
8230                     $ok++;
8231                 }
8232                 CPAN->debug(sprintf("need_module[%s]available_file[%s]".
8233                                     "available_version[%s]rq[%s]ok[%d]",
8234                                     $need_module,
8235                                     $available_file,
8236                                     $available_version,
8237                                     CPAN::Version->readable($rq),
8238                                     $ok,
8239                                    )) if $CPAN::DEBUG;
8240             }
8241             next NEED if $ok == @all_requirements;
8242         }
8243
8244         if ($need_module eq "perl") {
8245             return ["perl", $need_version];
8246         }
8247         $self->{sponsored_mods}{$need_module} ||= 0;
8248         CPAN->debug("need_module[$need_module]s/s/n[$self->{sponsored_mods}{$need_module}]") if $CPAN::DEBUG;
8249         if ($self->{sponsored_mods}{$need_module}++) {
8250             # We have already sponsored it and for some reason it's still
8251             # not available. So we do ... what??
8252
8253             # if we push it again, we have a potential infinite loop
8254
8255             # The following "next" was a very problematic construct.
8256             # It helped a lot but broke some day and had to be
8257             # replaced.
8258
8259             # We must be able to deal with modules that come again and
8260             # again as a prereq and have themselves prereqs and the
8261             # queue becomes long but finally we would find the correct
8262             # order. The RecursiveDependency check should trigger a
8263             # die when it's becoming too weird. Unfortunately removing
8264             # this next breaks many other things.
8265
8266             # The bug that brought this up is described in Todo under
8267             # "5.8.9 cannot install Compress::Zlib"
8268
8269             # next; # this is the next that had to go away
8270
8271             # The following "next NEED" are fine and the error message
8272             # explains well what is going on. For example when the DBI
8273             # fails and consequently DBD::SQLite fails and now we are
8274             # processing CPAN::SQLite. Then we must have a "next" for
8275             # DBD::SQLite. How can we get it and how can we identify
8276             # all other cases we must identify?
8277
8278             my $do = $nmo->distribution;
8279             next NEED unless $do; # not on CPAN
8280             if (CPAN::Version->vcmp($need_version, $nmo->{CPAN_VERSION}) > 0){
8281                 $CPAN::Frontend->mywarn("Warning: Prerequisite ".
8282                                         "'$need_module => $need_version' ".
8283                                         "for '$self->{ID}' seems ".
8284                                         "not available according the the indexes\n"
8285                                        );
8286                 next NEED;
8287             }
8288           NOSAYER: for my $nosayer (
8289                                     "unwrapped",
8290                                     "writemakefile",
8291                                     "signature_verify",
8292                                     "make",
8293                                     "make_test",
8294                                     "install",
8295                                     "make_clean",
8296                                    ) {
8297                 if ($do->{$nosayer}) {
8298                     if (UNIVERSAL::can($do->{$nosayer},"failed") ?
8299                         $do->{$nosayer}->failed :
8300                         $do->{$nosayer} =~ /^NO/) {
8301                         if ($nosayer eq "make_test"
8302                             &&
8303                             $do->{make_test}{COMMANDID} != $CPAN::CurrentCommandId
8304                            ) {
8305                             next NOSAYER;
8306                         }
8307                         $CPAN::Frontend->mywarn("Warning: Prerequisite ".
8308                                                 "'$need_module => $need_version' ".
8309                                                 "for '$self->{ID}' failed when ".
8310                                                 "processing '$do->{ID}' with ".
8311                                                 "'$nosayer => $do->{$nosayer}'. Continuing, ".
8312                                                 "but chances to succeed are limited.\n"
8313                                                );
8314                         next NEED;
8315                     } else { # the other guy succeeded
8316                         if ($nosayer eq "install") {
8317                             # we had this with
8318                             # DMAKI/DateTime-Calendar-Chinese-0.05.tar.gz
8319                             # 2007-03
8320                             $CPAN::Frontend->mywarn("Warning: Prerequisite ".
8321                                                     "'$need_module => $need_version' ".
8322                                                     "for '$self->{ID}' already installed ".
8323                                                     "but installation looks suspicious. ".
8324                                                     "Skipping another installation attempt, ".
8325                                                     "to prevent looping endlessly.\n"
8326                                                    );
8327                             next NEED;
8328                         }
8329                     }
8330                 }
8331             }
8332         }
8333         my $needed_as = exists $prereq_pm->{requires}{$need_module} ? "r" : "b";
8334         push @need, [$need_module,$needed_as];
8335     }
8336     my @unfolded = map { "[".join(",",@$_)."]" } @need;
8337     CPAN->debug("returning from unsat_prereq[@unfolded]") if $CPAN::DEBUG;
8338     @need;
8339 }
8340
8341 #-> sub CPAN::Distribution::read_yaml ;
8342 sub read_yaml {
8343     my($self) = @_;
8344     return $self->{yaml_content} if exists $self->{yaml_content};
8345     my $build_dir = $self->{build_dir};
8346     my $yaml = File::Spec->catfile($build_dir,"META.yml");
8347     $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
8348     return unless -f $yaml;
8349     eval { $self->{yaml_content} = CPAN->_yaml_loadfile($yaml)->[0]; };
8350     if ($@) {
8351         $CPAN::Frontend->mywarn("Could not read ".
8352                                 "'$yaml'. Falling back to other ".
8353                                 "methods to determine prerequisites\n");
8354         return $self->{yaml_content} = undef; # if we die, then we
8355                                               # cannot read YAML's own
8356                                               # META.yml
8357     }
8358     # not "authoritative"
8359     if (not exists $self->{yaml_content}{dynamic_config}
8360         or $self->{yaml_content}{dynamic_config}
8361        ) {
8362         $self->{yaml_content} = undef;
8363     }
8364     $self->debug(sprintf "yaml_content[%s]", $self->{yaml_content} || "UNDEF")
8365         if $CPAN::DEBUG;
8366     return $self->{yaml_content};
8367 }
8368
8369 #-> sub CPAN::Distribution::prereq_pm ;
8370 sub prereq_pm {
8371     my($self) = @_;
8372     $self->{prereq_pm_detected} ||= 0;
8373     CPAN->debug("ID[$self->{ID}]prereq_pm_detected[$self->{prereq_pm_detected}]") if $CPAN::DEBUG;
8374     return $self->{prereq_pm} if $self->{prereq_pm_detected};
8375     return unless $self->{writemakefile}  # no need to have succeeded
8376                                           # but we must have run it
8377         || $self->{modulebuild};
8378     CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
8379                 $self->{writemakefile}||"",
8380                 $self->{modulebuild}||"",
8381                ) if $CPAN::DEBUG;
8382     my($req,$breq);
8383     if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
8384         $req =  $yaml->{requires} || {};
8385         $breq =  $yaml->{build_requires} || {};
8386         undef $req unless ref $req eq "HASH" && %$req;
8387         if ($req) {
8388             if ($yaml->{generated_by} &&
8389                 $yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
8390                 my $eummv = do { local $^W = 0; $1+0; };
8391                 if ($eummv < 6.2501) {
8392                     # thanks to Slaven for digging that out: MM before
8393                     # that could be wrong because it could reflect a
8394                     # previous release
8395                     undef $req;
8396                 }
8397             }
8398             my $areq;
8399             my $do_replace;
8400             while (my($k,$v) = each %{$req||{}}) {
8401                 if ($v =~ /\d/) {
8402                     $areq->{$k} = $v;
8403                 } elsif ($k =~ /[A-Za-z]/ &&
8404                          $v =~ /[A-Za-z]/ &&
8405                          $CPAN::META->exists("Module",$v)
8406                         ) {
8407                     $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
8408                                             "requires hash: $k => $v; I'll take both ".
8409                                             "key and value as a module name\n");
8410                     $CPAN::Frontend->mysleep(1);
8411                     $areq->{$k} = 0;
8412                     $areq->{$v} = 0;
8413                     $do_replace++;
8414                 }
8415             }
8416             $req = $areq if $do_replace;
8417         }
8418     }
8419     unless ($req || $breq) {
8420         my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
8421         my $makefile = File::Spec->catfile($build_dir,"Makefile");
8422         my $fh;
8423         if (-f $makefile
8424             and
8425             $fh = FileHandle->new("<$makefile\0")) {
8426             CPAN->debug("Getting prereq from Makefile") if $CPAN::DEBUG;
8427             local($/) = "\n";
8428             while (<$fh>) {
8429                 last if /MakeMaker post_initialize section/;
8430                 my($p) = m{^[\#]
8431                            \s+PREREQ_PM\s+=>\s+(.+)
8432                        }x;
8433                 next unless $p;
8434                 # warn "Found prereq expr[$p]";
8435
8436                 #  Regexp modified by A.Speer to remember actual version of file
8437                 #  PREREQ_PM hash key wants, then add to
8438                 while ( $p =~ m/(?:\s)([\w\:]+)=>(q\[.*?\]|undef),?/g ) {
8439                     # In case a prereq is mentioned twice, complain.
8440                     if ( defined $req->{$1} ) {
8441                         warn "Warning: PREREQ_PM mentions $1 more than once, ".
8442                             "last mention wins";
8443                     }
8444                     my($m,$n) = ($1,$2);
8445                     if ($n =~ /^q\[(.*?)\]$/) {
8446                         $n = $1;
8447                     }
8448                     $req->{$m} = $n;
8449                 }
8450                 last;
8451             }
8452         }
8453     }
8454     unless ($req || $breq) {
8455         my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
8456         my $buildfile = File::Spec->catfile($build_dir,"Build");
8457         if (-f $buildfile) {
8458             CPAN->debug("Found '$buildfile'") if $CPAN::DEBUG;
8459             my $build_prereqs = File::Spec->catfile($build_dir,"_build","prereqs");
8460             if (-f $build_prereqs) {
8461                 CPAN->debug("Getting prerequisites from '$build_prereqs'") if $CPAN::DEBUG;
8462                 my $content = do { local *FH;
8463                                    open FH, $build_prereqs
8464                                        or $CPAN::Frontend->mydie("Could not open ".
8465                                                                  "'$build_prereqs': $!");
8466                                    local $/;
8467                                    <FH>;
8468                                };
8469                 my $bphash = eval $content;
8470                 if ($@) {
8471                 } else {
8472                     $req  = $bphash->{requires} || +{};
8473                     $breq = $bphash->{build_requires} || +{};
8474                 }
8475             }
8476         }
8477     }
8478     if (-f "Build.PL"
8479         && ! -f "Makefile.PL"
8480         && ! exists $req->{"Module::Build"}
8481         && ! $CPAN::META->has_inst("Module::Build")) {
8482         $CPAN::Frontend->mywarn("  Warning: CPAN.pm discovered Module::Build as ".
8483                                 "undeclared prerequisite.\n".
8484                                 "  Adding it now as such.\n"
8485                                );
8486         $CPAN::Frontend->mysleep(5);
8487         $req->{"Module::Build"} = 0;
8488         delete $self->{writemakefile};
8489     }
8490     if ($req || $breq) {
8491         $self->{prereq_pm_detected}++;
8492         return $self->{prereq_pm} = { requires => $req, build_requires => $breq };
8493     }
8494 }
8495
8496 #-> sub CPAN::Distribution::test ;
8497 sub test {
8498     my($self) = @_;
8499     if (my $goto = $self->prefs->{goto}) {
8500         return $self->goto($goto);
8501     }
8502     $self->make;
8503     if ($CPAN::Signal) {
8504       delete $self->{force_update};
8505       return;
8506     }
8507     # warn "XDEBUG: checking for notest: $self->{notest} $self";
8508     if ($self->{notest}) {
8509         $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
8510         return 1;
8511     }
8512
8513     my $make = $self->{modulebuild} ? "Build" : "make";
8514
8515     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
8516                            ? $ENV{PERL5LIB}
8517                            : ($ENV{PERLLIB} || "");
8518
8519     $CPAN::META->set_perl5lib;
8520     local $ENV{MAKEFLAGS}; # protect us from outer make calls
8521
8522     $CPAN::Frontend->myprint("Running $make test\n");
8523
8524   EXCUSE: {
8525         my @e;
8526         if ($self->{make} or $self->{later}) {
8527             # go ahead
8528         } else {
8529             push @e,
8530                 "Make had some problems, won't test";
8531         }
8532
8533         exists $self->{make} and
8534             (
8535              UNIVERSAL::can($self->{make},"failed") ?
8536              $self->{make}->failed :
8537              $self->{make} =~ /^NO/
8538             ) and push @e, "Can't test without successful make";
8539         $self->{badtestcnt} ||= 0;
8540         if ($self->{badtestcnt} > 0) {
8541             require Data::Dumper;
8542             CPAN->debug(sprintf "NOREPEAT[%s]", Data::Dumper::Dumper($self)) if $CPAN::DEBUG;
8543             push @e, "Won't repeat unsuccessful test during this command";
8544         }
8545
8546         push @e, $self->{later} if $self->{later};
8547         push @e, $self->{configure_requires_later} if $self->{configure_requires_later};
8548
8549         if (exists $self->{build_dir}) {
8550             if (exists $self->{make_test}) {
8551                 if (
8552                     UNIVERSAL::can($self->{make_test},"failed") ?
8553                     $self->{make_test}->failed :
8554                     $self->{make_test} =~ /^NO/
8555                    ) {
8556                     if (
8557                         UNIVERSAL::can($self->{make_test},"commandid")
8558                         &&
8559                         $self->{make_test}->commandid == $CPAN::CurrentCommandId
8560                        ) {
8561                         push @e, "Has already been tested within this command";
8562                     }
8563                 } else {
8564                     push @e, "Has already been tested successfully";
8565                 }
8566             }
8567         } elsif (!@e) {
8568             push @e, "Has no own directory";
8569         }
8570         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
8571         unless (chdir $self->{build_dir}) {
8572             push @e, "Couldn't chdir to '$self->{build_dir}': $!";
8573         }
8574         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
8575     }
8576     $self->debug("Changed directory to $self->{build_dir}")
8577         if $CPAN::DEBUG;
8578
8579     if ($^O eq 'MacOS') {
8580         Mac::BuildTools::make_test($self);
8581         return;
8582     }
8583
8584     if ($self->{modulebuild}) {
8585         my $v = CPAN::Shell->expand("Module","Test::Harness")->inst_version;
8586         if (CPAN::Version->vlt($v,2.62)) {
8587             $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
8588   '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n});
8589             $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old");
8590             return;
8591         }
8592     }
8593
8594     my $system;
8595     my $prefs_test = $self->prefs->{test};
8596     if (my $commandline
8597         = exists $prefs_test->{commandline} ? $prefs_test->{commandline} : "") {
8598         $system = $commandline;
8599         $ENV{PERL} = CPAN::find_perl;
8600     } elsif ($self->{modulebuild}) {
8601         $system = sprintf "%s test", $self->_build_command();
8602     } else {
8603         $system = join " ", $self->_make_command(), "test";
8604     }
8605     my $make_test_arg = $self->make_x_arg("test");
8606     $system = sprintf("%s%s",
8607                       $system,
8608                       $make_test_arg ? " $make_test_arg" : "",
8609                      );
8610     my($tests_ok);
8611     my %env;
8612     while (my($k,$v) = each %ENV) {
8613         next unless defined $v;
8614         $env{$k} = $v;
8615     }
8616     local %ENV = %env;
8617     if (my $env = $self->prefs->{test}{env}) {
8618         for my $e (keys %$env) {
8619             $ENV{$e} = $env->{$e};
8620         }
8621     }
8622     my $expect_model = $self->_prefs_with_expect("test");
8623     my $want_expect = 0;
8624     if ( $expect_model && @{$expect_model->{talk}} ) {
8625         my $can_expect = $CPAN::META->has_inst("Expect");
8626         if ($can_expect) {
8627             $want_expect = 1;
8628         } else {
8629             $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
8630                                     "testing without\n");
8631         }
8632     }
8633     if ($want_expect) {
8634         if ($self->_should_report('test')) {
8635             $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ".
8636                                     "not supported when distroprefs specify ".
8637                                     "an interactive test\n");
8638         }
8639         $tests_ok = $self->_run_via_expect($system,$expect_model) == 0;
8640     } elsif ( $self->_should_report('test') ) {
8641         $tests_ok = CPAN::Reporter::test($self, $system);
8642     } else {
8643         $tests_ok = system($system) == 0;
8644     }
8645     $self->introduce_myself;
8646     if ( $tests_ok ) {
8647         {
8648             my @prereq;
8649
8650             # local $CPAN::DEBUG = 16; # Distribution
8651             for my $m (keys %{$self->{sponsored_mods}}) {
8652                 next unless $self->{sponsored_mods}{$m} > 0;
8653                 my $m_obj = CPAN::Shell->expand("Module",$m) or next;
8654                 # XXX we need available_version which reflects
8655                 # $ENV{PERL5LIB} so that already tested but not yet
8656                 # installed modules are counted.
8657                 my $available_version = $m_obj->available_version;
8658                 my $available_file = $m_obj->available_file;
8659                 if ($available_version &&
8660                     !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m})
8661                    ) {
8662                     CPAN->debug("m[$m] good enough available_version[$available_version]")
8663                         if $CPAN::DEBUG;
8664                 } elsif ($available_file
8665                          && (
8666                              !$self->{prereq_pm}{$m}
8667                              ||
8668                              $self->{prereq_pm}{$m} == 0
8669                             )
8670                         ) {
8671                     # lex Class::Accessor::Chained::Fast which has no $VERSION
8672                     CPAN->debug("m[$m] have available_file[$available_file]")
8673                         if $CPAN::DEBUG;
8674                 } else {
8675                     push @prereq, $m;
8676                 }
8677             }
8678             if (@prereq) {
8679                 my $cnt = @prereq;
8680                 my $which = join ",", @prereq;
8681                 my $but = $cnt == 1 ? "one dependency not OK ($which)" :
8682                     "$cnt dependencies missing ($which)";
8683                 $CPAN::Frontend->mywarn("Tests succeeded but $but\n");
8684                 $self->{make_test} = CPAN::Distrostatus->new("NO $but");
8685                 $self->store_persistent_state;
8686                 return $self->goodbye("[dependencies] -- NA");
8687             }
8688         }
8689
8690         $CPAN::Frontend->myprint("  $system -- OK\n");
8691         $self->{make_test} = CPAN::Distrostatus->new("YES");
8692         $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
8693         # probably impossible to need the next line because badtestcnt
8694         # has a lifespan of one command
8695         delete $self->{badtestcnt};
8696     } else {
8697         $self->{make_test} = CPAN::Distrostatus->new("NO");
8698         $self->{badtestcnt}++;
8699         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
8700         CPAN::Shell->optprint
8701               ("hint",
8702                sprintf
8703                ("//hint// to see the cpan-testers results for installing this module, try:
8704   reports %s\n",
8705                 $self->pretty_id));
8706     }
8707     $self->store_persistent_state;
8708 }
8709
8710 sub _prefs_with_expect {
8711     my($self,$where) = @_;
8712     return unless my $prefs = $self->prefs;
8713     return unless my $where_prefs = $prefs->{$where};
8714     if ($where_prefs->{expect}) {
8715         return {
8716                 mode => "deterministic",
8717                 timeout => 15,
8718                 talk => $where_prefs->{expect},
8719                };
8720     } elsif ($where_prefs->{"eexpect"}) {
8721         return $where_prefs->{"eexpect"};
8722     }
8723     return;
8724 }
8725
8726 #-> sub CPAN::Distribution::clean ;
8727 sub clean {
8728     my($self) = @_;
8729     my $make = $self->{modulebuild} ? "Build" : "make";
8730     $CPAN::Frontend->myprint("Running $make clean\n");
8731     unless (exists $self->{archived}) {
8732         $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped".
8733                                 "/untarred, nothing done\n");
8734         return 1;
8735     }
8736     unless (exists $self->{build_dir}) {
8737         $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
8738         return 1;
8739     }
8740     if (exists $self->{writemakefile}
8741         and $self->{writemakefile}->failed
8742        ) {
8743         $CPAN::Frontend->mywarn("No Makefile, don't know how to 'make clean'\n");
8744         return 1;
8745     }
8746   EXCUSE: {
8747         my @e;
8748         exists $self->{make_clean} and $self->{make_clean} eq "YES" and
8749             push @e, "make clean already called once";
8750         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
8751     }
8752     chdir $self->{build_dir} or
8753         Carp::confess("Couldn't chdir to $self->{build_dir}: $!");
8754     $self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG;
8755
8756     if ($^O eq 'MacOS') {
8757         Mac::BuildTools::make_clean($self);
8758         return;
8759     }
8760
8761     my $system;
8762     if ($self->{modulebuild}) {
8763         unless (-f "Build") {
8764             my $cwd = CPAN::anycwd();
8765             $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
8766                                     " in cwd[$cwd]. Danger, Will Robinson!");
8767             $CPAN::Frontend->mysleep(5);
8768         }
8769         $system = sprintf "%s clean", $self->_build_command();
8770     } else {
8771         $system  = join " ", $self->_make_command(), "clean";
8772     }
8773     my $system_ok = system($system) == 0;
8774     $self->introduce_myself;
8775     if ( $system_ok ) {
8776       $CPAN::Frontend->myprint("  $system -- OK\n");
8777
8778       # $self->force;
8779
8780       # Jost Krieger pointed out that this "force" was wrong because
8781       # it has the effect that the next "install" on this distribution
8782       # will untar everything again. Instead we should bring the
8783       # object's state back to where it is after untarring.
8784
8785       for my $k (qw(
8786                     force_update
8787                     install
8788                     writemakefile
8789                     make
8790                     make_test
8791                    )) {
8792           delete $self->{$k};
8793       }
8794       $self->{make_clean} = CPAN::Distrostatus->new("YES");
8795
8796     } else {
8797       # Hmmm, what to do if make clean failed?
8798
8799       $self->{make_clean} = CPAN::Distrostatus->new("NO");
8800       $CPAN::Frontend->mywarn(qq{  $system -- NOT OK\n});
8801
8802       # 2006-02-27: seems silly to me to force a make now
8803       # $self->force("make"); # so that this directory won't be used again
8804
8805     }
8806     $self->store_persistent_state;
8807 }
8808
8809 #-> sub CPAN::Distribution::goto ;
8810 sub goto {
8811     my($self,$goto) = @_;
8812     $goto = $self->normalize($goto);
8813     my $why = sprintf(
8814                       "Goto '$goto' via prefs file '%s' doc %d",
8815                       $self->{prefs_file},
8816                       $self->{prefs_file_doc},
8817                      );
8818     $self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
8819     # 2007-07-16 akoenig : Better than NA would be if we could inherit
8820     # the status of the $goto distro but given the exceptional nature
8821     # of 'goto' I feel reluctant to implement it
8822     my $goodbye_message = "[goto] -- NA $why";
8823     $self->goodbye($goodbye_message);
8824
8825     # inject into the queue
8826
8827     CPAN::Queue->delete($self->id);
8828     CPAN::Queue->jumpqueue({qmod => $goto, reqtype => $self->{reqtype}});
8829
8830     # and run where we left off
8831
8832     my($method) = (caller(1))[3];
8833     CPAN->instance("CPAN::Distribution",$goto)->$method();
8834     CPAN::Queue->delete_first($goto);
8835 }
8836
8837 #-> sub CPAN::Distribution::install ;
8838 sub install {
8839     my($self) = @_;
8840     if (my $goto = $self->prefs->{goto}) {
8841         return $self->goto($goto);
8842     }
8843     # $DB::single=1;
8844     unless ($self->{badtestcnt}) {
8845         $self->test;
8846     }
8847     if ($CPAN::Signal) {
8848       delete $self->{force_update};
8849       return;
8850     }
8851     my $make = $self->{modulebuild} ? "Build" : "make";
8852     $CPAN::Frontend->myprint("Running $make install\n");
8853   EXCUSE: {
8854         my @e;
8855         if ($self->{make} or $self->{later}) {
8856             # go ahead
8857         } else {
8858             push @e,
8859                 "Make had some problems, won't install";
8860         }
8861
8862         exists $self->{make} and
8863             (
8864              UNIVERSAL::can($self->{make},"failed") ?
8865              $self->{make}->failed :
8866              $self->{make} =~ /^NO/
8867             ) and
8868             push @e, "Make had returned bad status, install seems impossible";
8869
8870         if (exists $self->{build_dir}) {
8871         } elsif (!@e) {
8872             push @e, "Has no own directory";
8873         }
8874
8875         if (exists $self->{make_test} and
8876             (
8877              UNIVERSAL::can($self->{make_test},"failed") ?
8878              $self->{make_test}->failed :
8879              $self->{make_test} =~ /^NO/
8880             )) {
8881             if ($self->{force_update}) {
8882                 $self->{make_test}->text("FAILED but failure ignored because ".
8883                                          "'force' in effect");
8884             } else {
8885                 push @e, "make test had returned bad status, ".
8886                     "won't install without force"
8887             }
8888         }
8889         if (exists $self->{install}) {
8890             if (UNIVERSAL::can($self->{install},"text") ?
8891                 $self->{install}->text eq "YES" :
8892                 $self->{install} =~ /^YES/
8893                ) {
8894                 $CPAN::Frontend->myprint("  Already done\n");
8895                 $CPAN::META->is_installed($self->{build_dir});
8896                 return 1;
8897             } else {
8898                 # comment in Todo on 2006-02-11; maybe retry?
8899                 push @e, "Already tried without success";
8900             }
8901         }
8902
8903         push @e, $self->{later} if $self->{later};
8904         push @e, $self->{configure_requires_later} if $self->{configure_requires_later};
8905
8906         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
8907         unless (chdir $self->{build_dir}) {
8908             push @e, "Couldn't chdir to '$self->{build_dir}': $!";
8909         }
8910         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
8911     }
8912     $self->debug("Changed directory to $self->{build_dir}")
8913         if $CPAN::DEBUG;
8914
8915     if ($^O eq 'MacOS') {
8916         Mac::BuildTools::make_install($self);
8917         return;
8918     }
8919
8920     my $system;
8921     if (my $commandline = $self->prefs->{install}{commandline}) {
8922         $system = $commandline;
8923         $ENV{PERL} = CPAN::find_perl;
8924     } elsif ($self->{modulebuild}) {
8925         my($mbuild_install_build_command) =
8926             exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
8927                 $CPAN::Config->{mbuild_install_build_command} ?
8928                     $CPAN::Config->{mbuild_install_build_command} :
8929                         $self->_build_command();
8930         $system = sprintf("%s install %s",
8931                           $mbuild_install_build_command,
8932                           $CPAN::Config->{mbuild_install_arg},
8933                          );
8934     } else {
8935         my($make_install_make_command) =
8936             CPAN::HandleConfig->prefs_lookup($self,
8937                                              q{make_install_make_command})
8938                   || $self->_make_command();
8939         $system = sprintf("%s install %s",
8940                           $make_install_make_command,
8941                           $CPAN::Config->{make_install_arg},
8942                          );
8943     }
8944
8945     my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 ";
8946     my $brip = CPAN::HandleConfig->prefs_lookup($self,
8947                                                 q{build_requires_install_policy});
8948     $brip ||="ask/yes";
8949     my $id = $self->id;
8950     my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command
8951     my $want_install = "yes";
8952     if ($reqtype eq "b") {
8953         if ($brip eq "no") {
8954             $want_install = "no";
8955         } elsif ($brip =~ m|^ask/(.+)|) {
8956             my $default = $1;
8957             $default = "yes" unless $default =~ /^(y|n)/i;
8958             $want_install =
8959                 CPAN::Shell::colorable_makemaker_prompt
8960                       ("$id is just needed temporarily during building or testing. ".
8961                        "Do you want to install it permanently? (Y/n)",
8962                        $default);
8963         }
8964     }
8965     unless ($want_install =~ /^y/i) {
8966         my $is_only = "is only 'build_requires'";
8967         $CPAN::Frontend->mywarn("Not installing because $is_only\n");
8968         $self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
8969         delete $self->{force_update};
8970         return;
8971     }
8972     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
8973                            ? $ENV{PERL5LIB}
8974                            : ($ENV{PERLLIB} || "");
8975
8976     $CPAN::META->set_perl5lib;
8977     my($pipe) = FileHandle->new("$system $stderr |");
8978     my($makeout) = "";
8979     while (<$pipe>) {
8980         print $_; # intentionally NOT use Frontend->myprint because it
8981                   # looks irritating when we markup in color what we
8982                   # just pass through from an external program
8983         $makeout .= $_;
8984     }
8985     $pipe->close;
8986     my $close_ok = $? == 0;
8987     $self->introduce_myself;
8988     if ( $close_ok ) {
8989         $CPAN::Frontend->myprint("  $system -- OK\n");
8990         $CPAN::META->is_installed($self->{build_dir});
8991         $self->{install} = CPAN::Distrostatus->new("YES");
8992     } else {
8993         $self->{install} = CPAN::Distrostatus->new("NO");
8994         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
8995         my $mimc =
8996             CPAN::HandleConfig->prefs_lookup($self,
8997                                              q{make_install_make_command});
8998         if (
8999             $makeout =~ /permission/s
9000             && $> > 0
9001             && (
9002                 ! $mimc
9003                 || $mimc eq (CPAN::HandleConfig->prefs_lookup($self,
9004                                                               q{make}))
9005                )
9006            ) {
9007             $CPAN::Frontend->myprint(
9008                                      qq{----\n}.
9009                                      qq{  You may have to su }.
9010                                      qq{to root to install the package\n}.
9011                                      qq{  (Or you may want to run something like\n}.
9012                                      qq{    o conf make_install_make_command 'sudo make'\n}.
9013                                      qq{  to raise your permissions.}
9014                                     );
9015         }
9016     }
9017     delete $self->{force_update};
9018     # $DB::single = 1;
9019     $self->store_persistent_state;
9020 }
9021
9022 sub introduce_myself {
9023     my($self) = @_;
9024     $CPAN::Frontend->myprint(sprintf("  %s\n",$self->pretty_id));
9025 }
9026
9027 #-> sub CPAN::Distribution::dir ;
9028 sub dir {
9029     shift->{build_dir};
9030 }
9031
9032 #-> sub CPAN::Distribution::perldoc ;
9033 sub perldoc {
9034     my($self) = @_;
9035
9036     my($dist) = $self->id;
9037     my $package = $self->called_for;
9038
9039     $self->_display_url( $CPAN::Defaultdocs . $package );
9040 }
9041
9042 #-> sub CPAN::Distribution::_check_binary ;
9043 sub _check_binary {
9044     my ($dist,$shell,$binary) = @_;
9045     my ($pid,$out);
9046
9047     $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
9048       if $CPAN::DEBUG;
9049
9050     if ($CPAN::META->has_inst("File::Which")) {
9051         return File::Which::which($binary);
9052     } else {
9053         local *README;
9054         $pid = open README, "which $binary|"
9055             or $CPAN::Frontend->mywarn(qq{Could not fork 'which $binary': $!\n});
9056         return unless $pid;
9057         while (<README>) {
9058             $out .= $_;
9059         }
9060         close README
9061             or $CPAN::Frontend->mywarn("Could not run 'which $binary': $!\n")
9062                 and return;
9063     }
9064
9065     $CPAN::Frontend->myprint(qq{   + $out \n})
9066       if $CPAN::DEBUG && $out;
9067
9068     return $out;
9069 }
9070
9071 #-> sub CPAN::Distribution::_display_url ;
9072 sub _display_url {
9073     my($self,$url) = @_;
9074     my($res,$saved_file,$pid,$out);
9075
9076     $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
9077       if $CPAN::DEBUG;
9078
9079     # should we define it in the config instead?
9080     my $html_converter = "html2text.pl";
9081
9082     my $web_browser = $CPAN::Config->{'lynx'} || undef;
9083     my $web_browser_out = $web_browser
9084         ? CPAN::Distribution->_check_binary($self,$web_browser)
9085         : undef;
9086
9087     if ($web_browser_out) {
9088         # web browser found, run the action
9089         my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
9090         $CPAN::Frontend->myprint(qq{system[$browser $url]})
9091             if $CPAN::DEBUG;
9092         $CPAN::Frontend->myprint(qq{
9093 Displaying URL
9094   $url
9095 with browser $browser
9096 });
9097         $CPAN::Frontend->mysleep(1);
9098         system("$browser $url");
9099         if ($saved_file) { 1 while unlink($saved_file) }
9100     } else {
9101         # web browser not found, let's try text only
9102         my $html_converter_out =
9103             CPAN::Distribution->_check_binary($self,$html_converter);
9104         $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out);
9105
9106         if ($html_converter_out ) {
9107             # html2text found, run it
9108             $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
9109             $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n})
9110                 unless defined($saved_file);
9111
9112             local *README;
9113             $pid = open README, "$html_converter $saved_file |"
9114                 or $CPAN::Frontend->mydie(qq{
9115 Could not fork '$html_converter $saved_file': $!});
9116             my($fh,$filename);
9117             if ($CPAN::META->has_usable("File::Temp")) {
9118                 $fh = File::Temp->new(
9119                                       dir      => File::Spec->tmpdir,
9120                                       template => 'cpan_htmlconvert_XXXX',
9121                                       suffix => '.txt',
9122                                       unlink => 0,
9123                                      );
9124                 $filename = $fh->filename;
9125             } else {
9126                 $filename = "cpan_htmlconvert_$$.txt";
9127                 $fh = FileHandle->new();
9128                 open $fh, ">$filename" or die;
9129             }
9130             while (<README>) {
9131                 $fh->print($_);
9132             }
9133             close README or
9134                 $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
9135             my $tmpin = $fh->filename;
9136             $CPAN::Frontend->myprint(sprintf(qq{
9137 Run '%s %s' and
9138 saved output to %s\n},
9139                                              $html_converter,
9140                                              $saved_file,
9141                                              $tmpin,
9142                                             )) if $CPAN::DEBUG;
9143             close $fh;
9144             local *FH;
9145             open FH, $tmpin
9146                 or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
9147             my $fh_pager = FileHandle->new;
9148             local($SIG{PIPE}) = "IGNORE";
9149             my $pager = $CPAN::Config->{'pager'} || "cat";
9150             $fh_pager->open("|$pager")
9151                 or $CPAN::Frontend->mydie(qq{
9152 Could not open pager '$pager': $!});
9153             $CPAN::Frontend->myprint(qq{
9154 Displaying URL
9155   $url
9156 with pager "$pager"
9157 });
9158             $CPAN::Frontend->mysleep(1);
9159             $fh_pager->print(<FH>);
9160             $fh_pager->close;
9161         } else {
9162             # coldn't find the web browser or html converter
9163             $CPAN::Frontend->myprint(qq{
9164 You need to install lynx or $html_converter to use this feature.});
9165         }
9166     }
9167 }
9168
9169 #-> sub CPAN::Distribution::_getsave_url ;
9170 sub _getsave_url {
9171     my($dist, $shell, $url) = @_;
9172
9173     $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
9174       if $CPAN::DEBUG;
9175
9176     my($fh,$filename);
9177     if ($CPAN::META->has_usable("File::Temp")) {
9178         $fh = File::Temp->new(
9179                               dir      => File::Spec->tmpdir,
9180                               template => "cpan_getsave_url_XXXX",
9181                               suffix => ".html",
9182                               unlink => 0,
9183                              );
9184         $filename = $fh->filename;
9185     } else {
9186         $fh = FileHandle->new;
9187         $filename = "cpan_getsave_url_$$.html";
9188     }
9189     my $tmpin = $filename;
9190     if ($CPAN::META->has_usable('LWP')) {
9191         $CPAN::Frontend->myprint("Fetching with LWP:
9192   $url
9193 ");
9194         my $Ua;
9195         CPAN::LWP::UserAgent->config;
9196         eval { $Ua = CPAN::LWP::UserAgent->new; };
9197         if ($@) {
9198             $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
9199             return;
9200         } else {
9201             my($var);
9202             $Ua->proxy('http', $var)
9203                 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
9204             $Ua->no_proxy($var)
9205                 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
9206         }
9207
9208         my $req = HTTP::Request->new(GET => $url);
9209         $req->header('Accept' => 'text/html');
9210         my $res = $Ua->request($req);
9211         if ($res->is_success) {
9212             $CPAN::Frontend->myprint(" + request successful.\n")
9213                 if $CPAN::DEBUG;
9214             print $fh $res->content;
9215             close $fh;
9216             $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
9217                 if $CPAN::DEBUG;
9218             return $tmpin;
9219         } else {
9220             $CPAN::Frontend->myprint(sprintf(
9221                                              "LWP failed with code[%s], message[%s]\n",
9222                                              $res->code,
9223                                              $res->message,
9224                                             ));
9225             return;
9226         }
9227     } else {
9228         $CPAN::Frontend->mywarn("  LWP not available\n");
9229         return;
9230     }
9231 }
9232
9233 #-> sub CPAN::Distribution::_build_command
9234 sub _build_command {
9235     my($self) = @_;
9236     if ($^O eq "MSWin32") { # special code needed at least up to
9237                             # Module::Build 0.2611 and 0.2706; a fix
9238                             # in M:B has been promised 2006-01-30
9239         my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
9240         return "$perl ./Build";
9241     }
9242     return "./Build";
9243 }
9244
9245 #-> sub CPAN::Distribution::_should_report
9246 sub _should_report {
9247     my($self, $phase) = @_;
9248     die "_should_report() requires a 'phase' argument"
9249         if ! defined $phase;
9250
9251     # configured
9252     my $test_report = CPAN::HandleConfig->prefs_lookup($self,
9253                                                        q{test_report});
9254     return unless $test_report;
9255
9256     # don't repeat if we cached a result
9257     return $self->{should_report}
9258         if exists $self->{should_report};
9259
9260     # available
9261     if ( ! $CPAN::META->has_inst("CPAN::Reporter")) {
9262         $CPAN::Frontend->mywarn(
9263             "CPAN::Reporter not installed.  No reports will be sent.\n"
9264         );
9265         return $self->{should_report} = 0;
9266     }
9267
9268     # capable
9269     my $crv = CPAN::Reporter->VERSION;
9270     if ( CPAN::Version->vlt( $crv, 0.99 ) ) {
9271         # don't cache $self->{should_report} -- need to check each phase
9272         if ( $phase eq 'test' ) {
9273             return 1;
9274         }
9275         else {
9276             $CPAN::Frontend->mywarn(
9277                 "Reporting on the '$phase' phase requires CPAN::Reporter 0.99, but \n" .
9278                 "you only have version $crv\.  Only 'test' phase reports will be sent.\n"
9279             );
9280             return;
9281         }
9282     }
9283
9284     # appropriate
9285     if ($self->is_dot_dist) {
9286         $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
9287                                 "for local directories\n");
9288         return $self->{should_report} = 0;
9289     }
9290     if ($self->prefs->{patches}
9291         &&
9292         @{$self->prefs->{patches}}
9293         &&
9294         $self->{patched}
9295        ) {
9296         $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
9297                                 "when the source has been patched\n");
9298         return $self->{should_report} = 0;
9299     }
9300
9301     # proceed and cache success
9302     return $self->{should_report} = 1;
9303 }
9304
9305 #-> sub CPAN::Distribution::reports
9306 sub reports {
9307     my($self) = @_;
9308     my $pathname = $self->id;
9309     $CPAN::Frontend->myprint("Distribution: $pathname\n");
9310
9311     unless ($CPAN::META->has_inst("CPAN::DistnameInfo")) {
9312         $CPAN::Frontend->mydie("CPAN::DistnameInfo not installed; cannot continue");
9313     }
9314     unless ($CPAN::META->has_usable("LWP")) {
9315         $CPAN::Frontend->mydie("LWP not installed; cannot continue");
9316     }
9317     unless ($CPAN::META->has_usable("File::Temp")) {
9318         $CPAN::Frontend->mydie("File::Temp not installed; cannot continue");
9319     }
9320
9321     my $d = CPAN::DistnameInfo->new($pathname);
9322
9323     my $dist      = $d->dist;      # "CPAN-DistnameInfo"
9324     my $version   = $d->version;   # "0.02"
9325     my $maturity  = $d->maturity;  # "released"
9326     my $filename  = $d->filename;  # "CPAN-DistnameInfo-0.02.tar.gz"
9327     my $cpanid    = $d->cpanid;    # "GBARR"
9328     my $distvname = $d->distvname; # "CPAN-DistnameInfo-0.02"
9329
9330     my $url = sprintf "http://cpantesters.perl.org/show/%s.yaml", $dist;
9331
9332     CPAN::LWP::UserAgent->config;
9333     my $Ua;
9334     eval { $Ua = CPAN::LWP::UserAgent->new; };
9335     if ($@) {
9336         $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
9337     }
9338     $CPAN::Frontend->myprint("Fetching '$url'...");
9339     my $resp = $Ua->get($url);
9340     unless ($resp->is_success) {
9341         $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
9342     }
9343     $CPAN::Frontend->myprint("DONE\n\n");
9344     my $yaml = $resp->content;
9345     # was fuer ein Umweg!
9346     my $fh = File::Temp->new(
9347                              dir      => File::Spec->tmpdir,
9348                              template => 'cpan_reports_XXXX',
9349                              suffix => '.yaml',
9350                              unlink => 0,
9351                             );
9352     my $tfilename = $fh->filename;
9353     print $fh $yaml;
9354     close $fh or $CPAN::Frontend->mydie("Could not close '$tfilename': $!");
9355     my $unserialized = CPAN->_yaml_loadfile($tfilename)->[0];
9356     unlink $tfilename or $CPAN::Frontend->mydie("Could not unlink '$tfilename': $!");
9357     my %other_versions;
9358     my $this_version_seen;
9359     for my $rep (@$unserialized) {
9360         my $rversion = $rep->{version};
9361         if ($rversion eq $version) {
9362             unless ($this_version_seen++) {
9363                 $CPAN::Frontend->myprint ("$rep->{version}:\n");
9364             }
9365             $CPAN::Frontend->myprint
9366                 (sprintf("%1s%1s%-4s %s on %s %s (%s)\n",
9367                          $rep->{archname} eq $Config::Config{archname}?"*":"",
9368                          $rep->{action}eq"PASS"?"+":$rep->{action}eq"FAIL"?"-":"",
9369                          $rep->{action},
9370                          $rep->{perl},
9371                          ucfirst $rep->{osname},
9372                          $rep->{osvers},
9373                          $rep->{archname},
9374                         ));
9375         } else {
9376             $other_versions{$rep->{version}}++;
9377         }
9378     }
9379     unless ($this_version_seen) {
9380         $CPAN::Frontend->myprint("No reports found for version '$version'
9381 Reports for other versions:\n");
9382         for my $v (sort keys %other_versions) {
9383             $CPAN::Frontend->myprint(" $v\: $other_versions{$v}\n");
9384         }
9385     }
9386     $url =~ s/\.yaml/.html/;
9387     $CPAN::Frontend->myprint("See $url for details\n");
9388 }
9389
9390 package CPAN::Bundle;
9391 use strict;
9392
9393 sub look {
9394     my $self = shift;
9395     $CPAN::Frontend->myprint($self->as_string);
9396 }
9397
9398 #-> CPAN::Bundle::undelay
9399 sub undelay {
9400     my $self = shift;
9401     delete $self->{later};
9402     for my $c ( $self->contains ) {
9403         my $obj = CPAN::Shell->expandany($c) or next;
9404         $obj->undelay;
9405     }
9406 }
9407
9408 # mark as dirty/clean
9409 #-> sub CPAN::Bundle::color_cmd_tmps ;
9410 sub color_cmd_tmps {
9411     my($self) = shift;
9412     my($depth) = shift || 0;
9413     my($color) = shift || 0;
9414     my($ancestors) = shift || [];
9415     # a module needs to recurse to its cpan_file, a distribution needs
9416     # to recurse into its prereq_pms, a bundle needs to recurse into its modules
9417
9418     return if exists $self->{incommandcolor}
9419         && $color==1
9420         && $self->{incommandcolor}==$color;
9421     if ($depth>=$CPAN::MAX_RECURSION) {
9422         die(CPAN::Exception::RecursiveDependency->new($ancestors));
9423     }
9424     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
9425
9426     for my $c ( $self->contains ) {
9427         my $obj = CPAN::Shell->expandany($c) or next;
9428         CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
9429         $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
9430     }
9431     # never reached code?
9432     #if ($color==0) {
9433       #delete $self->{badtestcnt};
9434     #}
9435     $self->{incommandcolor} = $color;
9436 }
9437
9438 #-> sub CPAN::Bundle::as_string ;
9439 sub as_string {
9440     my($self) = @_;
9441     $self->contains;
9442     # following line must be "=", not "||=" because we have a moving target
9443     $self->{INST_VERSION} = $self->inst_version;
9444     return $self->SUPER::as_string;
9445 }
9446
9447 #-> sub CPAN::Bundle::contains ;
9448 sub contains {
9449     my($self) = @_;
9450     my($inst_file) = $self->inst_file || "";
9451     my($id) = $self->id;
9452     $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
9453     if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) {
9454         undef $inst_file;
9455     }
9456     unless ($inst_file) {
9457         # Try to get at it in the cpan directory
9458         $self->debug("no inst_file") if $CPAN::DEBUG;
9459         my $cpan_file;
9460         $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
9461               $cpan_file = $self->cpan_file;
9462         if ($cpan_file eq "N/A") {
9463             $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
9464   Maybe stale symlink? Maybe removed during session? Giving up.\n");
9465         }
9466         my $dist = $CPAN::META->instance('CPAN::Distribution',
9467                                          $self->cpan_file);
9468         $self->debug("before get id[$dist->{ID}]") if $CPAN::DEBUG;
9469         $dist->get;
9470         $self->debug("after get id[$dist->{ID}]") if $CPAN::DEBUG;
9471         my($todir) = $CPAN::Config->{'cpan_home'};
9472         my(@me,$from,$to,$me);
9473         @me = split /::/, $self->id;
9474         $me[-1] .= ".pm";
9475         $me = File::Spec->catfile(@me);
9476         $from = $self->find_bundle_file($dist->{build_dir},join('/',@me));
9477         $to = File::Spec->catfile($todir,$me);
9478         File::Path::mkpath(File::Basename::dirname($to));
9479         File::Copy::copy($from, $to)
9480               or Carp::confess("Couldn't copy $from to $to: $!");
9481         $inst_file = $to;
9482     }
9483     my @result;
9484     my $fh = FileHandle->new;
9485     local $/ = "\n";
9486     open($fh,$inst_file) or die "Could not open '$inst_file': $!";
9487     my $in_cont = 0;
9488     $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
9489     while (<$fh>) {
9490         $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
9491             m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
9492         next unless $in_cont;
9493         next if /^=/;
9494         s/\#.*//;
9495         next if /^\s+$/;
9496         chomp;
9497         push @result, (split " ", $_, 2)[0];
9498     }
9499     close $fh;
9500     delete $self->{STATUS};
9501     $self->{CONTAINS} = \@result;
9502     $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
9503     unless (@result) {
9504         $CPAN::Frontend->mywarn(qq{
9505 The bundle file "$inst_file" may be a broken
9506 bundlefile. It seems not to contain any bundle definition.
9507 Please check the file and if it is bogus, please delete it.
9508 Sorry for the inconvenience.
9509 });
9510     }
9511     @result;
9512 }
9513
9514 #-> sub CPAN::Bundle::find_bundle_file
9515 # $where is in local format, $what is in unix format
9516 sub find_bundle_file {
9517     my($self,$where,$what) = @_;
9518     $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
9519 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
9520 ###    my $bu = File::Spec->catfile($where,$what);
9521 ###    return $bu if -f $bu;
9522     my $manifest = File::Spec->catfile($where,"MANIFEST");
9523     unless (-f $manifest) {
9524         require ExtUtils::Manifest;
9525         my $cwd = CPAN::anycwd();
9526         $self->safe_chdir($where);
9527         ExtUtils::Manifest::mkmanifest();
9528         $self->safe_chdir($cwd);
9529     }
9530     my $fh = FileHandle->new($manifest)
9531         or Carp::croak("Couldn't open $manifest: $!");
9532     local($/) = "\n";
9533     my $bundle_filename = $what;
9534     $bundle_filename =~ s|Bundle.*/||;
9535     my $bundle_unixpath;
9536     while (<$fh>) {
9537         next if /^\s*\#/;
9538         my($file) = /(\S+)/;
9539         if ($file =~ m|\Q$what\E$|) {
9540             $bundle_unixpath = $file;
9541             # return File::Spec->catfile($where,$bundle_unixpath); # bad
9542             last;
9543         }
9544         # retry if she managed to have no Bundle directory
9545         $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
9546     }
9547     return File::Spec->catfile($where, split /\//, $bundle_unixpath)
9548         if $bundle_unixpath;
9549     Carp::croak("Couldn't find a Bundle file in $where");
9550 }
9551
9552 # needs to work quite differently from Module::inst_file because of
9553 # cpan_home/Bundle/ directory and the possibility that we have
9554 # shadowing effect. As it makes no sense to take the first in @INC for
9555 # Bundles, we parse them all for $VERSION and take the newest.
9556
9557 #-> sub CPAN::Bundle::inst_file ;
9558 sub inst_file {
9559     my($self) = @_;
9560     my($inst_file);
9561     my(@me);
9562     @me = split /::/, $self->id;
9563     $me[-1] .= ".pm";
9564     my($incdir,$bestv);
9565     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
9566         my $bfile = File::Spec->catfile($incdir, @me);
9567         CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
9568         next unless -f $bfile;
9569         my $foundv = MM->parse_version($bfile);
9570         if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
9571             $self->{INST_FILE} = $bfile;
9572             $self->{INST_VERSION} = $bestv = $foundv;
9573         }
9574     }
9575     $self->{INST_FILE};
9576 }
9577
9578 #-> sub CPAN::Bundle::inst_version ;
9579 sub inst_version {
9580     my($self) = @_;
9581     $self->inst_file; # finds INST_VERSION as side effect
9582     $self->{INST_VERSION};
9583 }
9584
9585 #-> sub CPAN::Bundle::rematein ;
9586 sub rematein {
9587     my($self,$meth) = @_;
9588     $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
9589     my($id) = $self->id;
9590     Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
9591         unless $self->inst_file || $self->cpan_file;
9592     my($s,%fail);
9593     for $s ($self->contains) {
9594         my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
9595             $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
9596         if ($type eq 'CPAN::Distribution') {
9597             $CPAN::Frontend->mywarn(qq{
9598 The Bundle }.$self->id.qq{ contains
9599 explicitly a file '$s'.
9600 Going to $meth that.
9601 });
9602             $CPAN::Frontend->mysleep(5);
9603         }
9604         # possibly noisy action:
9605         $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
9606         my $obj = $CPAN::META->instance($type,$s);
9607         $obj->{reqtype} = $self->{reqtype};
9608         $obj->$meth();
9609     }
9610 }
9611
9612 # If a bundle contains another that contains an xs_file we have here,
9613 # we just don't bother I suppose
9614 #-> sub CPAN::Bundle::xs_file
9615 sub xs_file {
9616     return 0;
9617 }
9618
9619 #-> sub CPAN::Bundle::force ;
9620 sub fforce   { shift->rematein('fforce',@_); }
9621 #-> sub CPAN::Bundle::force ;
9622 sub force   { shift->rematein('force',@_); }
9623 #-> sub CPAN::Bundle::notest ;
9624 sub notest  { shift->rematein('notest',@_); }
9625 #-> sub CPAN::Bundle::get ;
9626 sub get     { shift->rematein('get',@_); }
9627 #-> sub CPAN::Bundle::make ;
9628 sub make    { shift->rematein('make',@_); }
9629 #-> sub CPAN::Bundle::test ;
9630 sub test    {
9631     my $self = shift;
9632     # $self->{badtestcnt} ||= 0;
9633     $self->rematein('test',@_);
9634 }
9635 #-> sub CPAN::Bundle::install ;
9636 sub install {
9637   my $self = shift;
9638   $self->rematein('install',@_);
9639 }
9640 #-> sub CPAN::Bundle::clean ;
9641 sub clean   { shift->rematein('clean',@_); }
9642
9643 #-> sub CPAN::Bundle::uptodate ;
9644 sub uptodate {
9645     my($self) = @_;
9646     return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
9647     my $c;
9648     foreach $c ($self->contains) {
9649         my $obj = CPAN::Shell->expandany($c);
9650         return 0 unless $obj->uptodate;
9651     }
9652     return 1;
9653 }
9654
9655 #-> sub CPAN::Bundle::readme ;
9656 sub readme  {
9657     my($self) = @_;
9658     my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
9659 No File found for bundle } . $self->id . qq{\n}), return;
9660     $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
9661     $CPAN::META->instance('CPAN::Distribution',$file)->readme;
9662 }
9663
9664 package CPAN::Module;
9665 use strict;
9666
9667 # Accessors
9668 #-> sub CPAN::Module::userid
9669 sub userid {
9670     my $self = shift;
9671     my $ro = $self->ro;
9672     return unless $ro;
9673     return $ro->{userid} || $ro->{CPAN_USERID};
9674 }
9675 #-> sub CPAN::Module::description
9676 sub description {
9677     my $self = shift;
9678     my $ro = $self->ro or return "";
9679     $ro->{description}
9680 }
9681
9682 #-> sub CPAN::Module::distribution
9683 sub distribution {
9684     my($self) = @_;
9685     CPAN::Shell->expand("Distribution",$self->cpan_file);
9686 }
9687
9688 #-> sub CPAN::Module::undelay
9689 sub undelay {
9690     my $self = shift;
9691     delete $self->{later};
9692     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
9693         $dist->undelay;
9694     }
9695 }
9696
9697 # mark as dirty/clean
9698 #-> sub CPAN::Module::color_cmd_tmps ;
9699 sub color_cmd_tmps {
9700     my($self) = shift;
9701     my($depth) = shift || 0;
9702     my($color) = shift || 0;
9703     my($ancestors) = shift || [];
9704     # a module needs to recurse to its cpan_file
9705
9706     return if exists $self->{incommandcolor}
9707         && $color==1
9708         && $self->{incommandcolor}==$color;
9709     return if $color==0 && !$self->{incommandcolor};
9710     if ($color>=1) {
9711         if ( $self->uptodate ) {
9712             $self->{incommandcolor} = $color;
9713             return;
9714         } elsif (my $have_version = $self->available_version) {
9715             # maybe what we have is good enough
9716             if (@$ancestors) {
9717                 my $who_asked_for_me = $ancestors->[-1];
9718                 my $obj = CPAN::Shell->expandany($who_asked_for_me);
9719                 if (0) {
9720                 } elsif ($obj->isa("CPAN::Bundle")) {
9721                     # bundles cannot specify a minimum version
9722                     return;
9723                 } elsif ($obj->isa("CPAN::Distribution")) {
9724                     if (my $prereq_pm = $obj->prereq_pm) {
9725                         for my $k (keys %$prereq_pm) {
9726                             if (my $want_version = $prereq_pm->{$k}{$self->id}) {
9727                                 if (CPAN::Version->vcmp($have_version,$want_version) >= 0) {
9728                                     $self->{incommandcolor} = $color;
9729                                     return;
9730                                 }
9731                             }
9732                         }
9733                     }
9734                 }
9735             }
9736         }
9737     } else {
9738         $self->{incommandcolor} = $color; # set me before recursion,
9739                                           # so we can break it
9740     }
9741     if ($depth>=$CPAN::MAX_RECURSION) {
9742         die(CPAN::Exception::RecursiveDependency->new($ancestors));
9743     }
9744     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
9745
9746     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
9747         $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
9748     }
9749     # unreached code?
9750     # if ($color==0) {
9751     #    delete $self->{badtestcnt};
9752     # }
9753     $self->{incommandcolor} = $color;
9754 }
9755
9756 #-> sub CPAN::Module::as_glimpse ;
9757 sub as_glimpse {
9758     my($self) = @_;
9759     my(@m);
9760     my $class = ref($self);
9761     $class =~ s/^CPAN:://;
9762     my $color_on = "";
9763     my $color_off = "";
9764     if (
9765         $CPAN::Shell::COLOR_REGISTERED
9766         &&
9767         $CPAN::META->has_inst("Term::ANSIColor")
9768         &&
9769         $self->description
9770        ) {
9771         $color_on = Term::ANSIColor::color("green");
9772         $color_off = Term::ANSIColor::color("reset");
9773     }
9774     my $uptodateness = " ";
9775         unless ($class eq "Bundle") {
9776                 my $u = $self->uptodate;
9777                 $uptodateness = $u ? "=" : "<" if defined $u;
9778         };
9779         my $id = do {
9780                 my $d = $self->distribution;
9781                 $d ? $d -> pretty_id : $self->cpan_userid;
9782         };
9783     push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n",
9784                      $class,
9785                      $uptodateness,
9786                      $color_on,
9787                      $self->id,
9788                      $color_off,
9789                                          $id,
9790                     );
9791     join "", @m;
9792 }
9793
9794 #-> sub CPAN::Module::dslip_status
9795 sub dslip_status {
9796     my($self) = @_;
9797     my($stat);
9798     # development status
9799     @{$stat->{D}}{qw,i c a b R M S,}     = qw,idea
9800                                               pre-alpha alpha beta released
9801                                               mature standard,;
9802     # support level
9803     @{$stat->{S}}{qw,m d u n a,}         = qw,mailing-list
9804                                               developer comp.lang.perl.*
9805                                               none abandoned,;
9806     # language
9807     @{$stat->{L}}{qw,p c + o h,}         = qw,perl C C++ other hybrid,;
9808     # interface
9809     @{$stat->{I}}{qw,f r O p h n,}       = qw,functions
9810                                               references+ties
9811                                               object-oriented pragma
9812                                               hybrid none,;
9813     # public licence
9814     @{$stat->{P}}{qw,p g l b a 2 o d r n,} = qw,Standard-Perl
9815                                               GPL LGPL
9816                                               BSD Artistic Artistic_2
9817                                               open-source
9818                                               distribution_allowed
9819                                               restricted_distribution
9820                                               no_licence,;
9821     for my $x (qw(d s l i p)) {
9822         $stat->{$x}{' '} = 'unknown';
9823         $stat->{$x}{'?'} = 'unknown';
9824     }
9825     my $ro = $self->ro;
9826     return +{} unless $ro && $ro->{statd};
9827     return {
9828             D  => $ro->{statd},
9829             S  => $ro->{stats},
9830             L  => $ro->{statl},
9831             I  => $ro->{stati},
9832             P  => $ro->{statp},
9833             DV => $stat->{D}{$ro->{statd}},
9834             SV => $stat->{S}{$ro->{stats}},
9835             LV => $stat->{L}{$ro->{statl}},
9836             IV => $stat->{I}{$ro->{stati}},
9837             PV => $stat->{P}{$ro->{statp}},
9838            };
9839 }
9840
9841 #-> sub CPAN::Module::as_string ;
9842 sub as_string {
9843     my($self) = @_;
9844     my(@m);
9845     CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
9846     my $class = ref($self);
9847     $class =~ s/^CPAN:://;
9848     local($^W) = 0;
9849     push @m, $class, " id = $self->{ID}\n";
9850     my $sprintf = "    %-12s %s\n";
9851     push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
9852         if $self->description;
9853     my $sprintf2 = "    %-12s %s (%s)\n";
9854     my($userid);
9855     $userid = $self->userid;
9856     if ( $userid ) {
9857         my $author;
9858         if ($author = CPAN::Shell->expand('Author',$userid)) {
9859             my $email = "";
9860             my $m; # old perls
9861             if ($m = $author->email) {
9862                 $email = " <$m>";
9863             }
9864             push @m, sprintf(
9865                              $sprintf2,
9866                              'CPAN_USERID',
9867                              $userid,
9868                              $author->fullname . $email
9869                             );
9870         }
9871     }
9872     push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
9873         if $self->cpan_version;
9874     if (my $cpan_file = $self->cpan_file) {
9875         push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
9876         if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
9877             my $upload_date = $dist->upload_date;
9878             if ($upload_date) {
9879                 push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
9880             }
9881         }
9882     }
9883     my $sprintf3 = "    %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n";
9884     my $dslip = $self->dslip_status;
9885     push @m, sprintf(
9886                      $sprintf3,
9887                      'DSLIP_STATUS',
9888                      @{$dslip}{qw(D S L I P DV SV LV IV PV)},
9889                     ) if $dslip->{D};
9890     my $local_file = $self->inst_file;
9891     unless ($self->{MANPAGE}) {
9892         my $manpage;
9893         if ($local_file) {
9894             $manpage = $self->manpage_headline($local_file);
9895         } else {
9896             # If we have already untarred it, we should look there
9897             my $dist = $CPAN::META->instance('CPAN::Distribution',
9898                                              $self->cpan_file);
9899             # warn "dist[$dist]";
9900             # mff=manifest file; mfh=manifest handle
9901             my($mff,$mfh);
9902             if (
9903                 $dist->{build_dir}
9904                 and
9905                 (-f  ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
9906                 and
9907                 $mfh = FileHandle->new($mff)
9908                ) {
9909                 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
9910                 my $lfre = $self->id; # local file RE
9911                 $lfre =~ s/::/./g;
9912                 $lfre .= "\\.pm\$";
9913                 my($lfl); # local file file
9914                 local $/ = "\n";
9915                 my(@mflines) = <$mfh>;
9916                 for (@mflines) {
9917                     s/^\s+//;
9918                     s/\s.*//s;
9919                 }
9920                 while (length($lfre)>5 and !$lfl) {
9921                     ($lfl) = grep /$lfre/, @mflines;
9922                     CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
9923                     $lfre =~ s/.+?\.//;
9924                 }
9925                 $lfl =~ s/\s.*//; # remove comments
9926                 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
9927                 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
9928                 # warn "lfl_abs[$lfl_abs]";
9929                 if (-f $lfl_abs) {
9930                     $manpage = $self->manpage_headline($lfl_abs);
9931                 }
9932             }
9933         }
9934         $self->{MANPAGE} = $manpage if $manpage;
9935     }
9936     my($item);
9937     for $item (qw/MANPAGE/) {
9938         push @m, sprintf($sprintf, $item, $self->{$item})
9939             if exists $self->{$item};
9940     }
9941     for $item (qw/CONTAINS/) {
9942         push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
9943             if exists $self->{$item} && @{$self->{$item}};
9944     }
9945     push @m, sprintf($sprintf, 'INST_FILE',
9946                      $local_file || "(not installed)");
9947     push @m, sprintf($sprintf, 'INST_VERSION',
9948                      $self->inst_version) if $local_file;
9949     join "", @m, "\n";
9950 }
9951
9952 #-> sub CPAN::Module::manpage_headline
9953 sub manpage_headline {
9954     my($self,$local_file) = @_;
9955     my(@local_file) = $local_file;
9956     $local_file =~ s/\.pm(?!\n)\Z/.pod/;
9957     push @local_file, $local_file;
9958     my(@result,$locf);
9959     for $locf (@local_file) {
9960         next unless -f $locf;
9961         my $fh = FileHandle->new($locf)
9962             or $Carp::Frontend->mydie("Couldn't open $locf: $!");
9963         my $inpod = 0;
9964         local $/ = "\n";
9965         while (<$fh>) {
9966             $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
9967                 m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
9968             next unless $inpod;
9969             next if /^=/;
9970             next if /^\s+$/;
9971             chomp;
9972             push @result, $_;
9973         }
9974         close $fh;
9975         last if @result;
9976     }
9977     for (@result) {
9978         s/^\s+//;
9979         s/\s+$//;
9980     }
9981     join " ", @result;
9982 }
9983
9984 #-> sub CPAN::Module::cpan_file ;
9985 # Note: also inherited by CPAN::Bundle
9986 sub cpan_file {
9987     my $self = shift;
9988     # CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
9989     unless ($self->ro) {
9990         CPAN::Index->reload;
9991     }
9992     my $ro = $self->ro;
9993     if ($ro && defined $ro->{CPAN_FILE}) {
9994         return $ro->{CPAN_FILE};
9995     } else {
9996         my $userid = $self->userid;
9997         if ( $userid ) {
9998             if ($CPAN::META->exists("CPAN::Author",$userid)) {
9999                 my $author = $CPAN::META->instance("CPAN::Author",
10000                                                    $userid);
10001                 my $fullname = $author->fullname;
10002                 my $email = $author->email;
10003                 unless (defined $fullname && defined $email) {
10004                     return sprintf("Contact Author %s",
10005                                    $userid,
10006                                   );
10007                 }
10008                 return "Contact Author $fullname <$email>";
10009             } else {
10010                 return "Contact Author $userid (Email address not available)";
10011             }
10012         } else {
10013             return "N/A";
10014         }
10015     }
10016 }
10017
10018 #-> sub CPAN::Module::cpan_version ;
10019 sub cpan_version {
10020     my $self = shift;
10021
10022     my $ro = $self->ro;
10023     unless ($ro) {
10024         # Can happen with modules that are not on CPAN
10025         $ro = {};
10026     }
10027     $ro->{CPAN_VERSION} = 'undef'
10028         unless defined $ro->{CPAN_VERSION};
10029     $ro->{CPAN_VERSION};
10030 }
10031
10032 #-> sub CPAN::Module::force ;
10033 sub force {
10034     my($self) = @_;
10035     $self->{force_update} = 1;
10036 }
10037
10038 #-> sub CPAN::Module::fforce ;
10039 sub fforce {
10040     my($self) = @_;
10041     $self->{force_update} = 2;
10042 }
10043
10044 #-> sub CPAN::Module::notest ;
10045 sub notest {
10046     my($self) = @_;
10047     # $CPAN::Frontend->mywarn("XDEBUG: set notest for Module");
10048     $self->{notest}++;
10049 }
10050
10051 #-> sub CPAN::Module::rematein ;
10052 sub rematein {
10053     my($self,$meth) = @_;
10054     $CPAN::Frontend->myprint(sprintf("Running %s for module '%s'\n",
10055                                      $meth,
10056                                      $self->id));
10057     my $cpan_file = $self->cpan_file;
10058     if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/) {
10059         $CPAN::Frontend->mywarn(sprintf qq{
10060   The module %s isn\'t available on CPAN.
10061
10062   Either the module has not yet been uploaded to CPAN, or it is
10063   temporary unavailable. Please contact the author to find out
10064   more about the status. Try 'i %s'.
10065 },
10066                                 $self->id,
10067                                 $self->id,
10068                                );
10069         return;
10070     }
10071     my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
10072     $pack->called_for($self->id);
10073     if (exists $self->{force_update}) {
10074         if ($self->{force_update} == 2) {
10075             $pack->fforce($meth);
10076         } else {
10077             $pack->force($meth);
10078         }
10079     }
10080     $pack->notest($meth) if exists $self->{notest} && $self->{notest};
10081
10082     $pack->{reqtype} ||= "";
10083     CPAN->debug("dist-reqtype[$pack->{reqtype}]".
10084                 "self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG;
10085         if ($pack->{reqtype}) {
10086             if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) {
10087                 $pack->{reqtype} = $self->{reqtype};
10088                 if (
10089                     exists $pack->{install}
10090                     &&
10091                     (
10092                      UNIVERSAL::can($pack->{install},"failed") ?
10093                      $pack->{install}->failed :
10094                      $pack->{install} =~ /^NO/
10095                     )
10096                    ) {
10097                     delete $pack->{install};
10098                     $CPAN::Frontend->mywarn
10099                         ("Promoting $pack->{ID} from 'build_requires' to 'requires'");
10100                 }
10101             }
10102         } else {
10103             $pack->{reqtype} = $self->{reqtype};
10104         }
10105
10106     my $success = eval {
10107         $pack->$meth();
10108     };
10109     my $err = $@;
10110     $pack->unforce if $pack->can("unforce") && exists $self->{force_update};
10111     $pack->unnotest if $pack->can("unnotest") && exists $self->{notest};
10112     delete $self->{force_update};
10113     delete $self->{notest};
10114     if ($err) {
10115         die $err;
10116     }
10117     return $success;
10118 }
10119
10120 #-> sub CPAN::Module::perldoc ;
10121 sub perldoc { shift->rematein('perldoc') }
10122 #-> sub CPAN::Module::readme ;
10123 sub readme  { shift->rematein('readme') }
10124 #-> sub CPAN::Module::look ;
10125 sub look    { shift->rematein('look') }
10126 #-> sub CPAN::Module::cvs_import ;
10127 sub cvs_import { shift->rematein('cvs_import') }
10128 #-> sub CPAN::Module::get ;
10129 sub get     { shift->rematein('get',@_) }
10130 #-> sub CPAN::Module::make ;
10131 sub make    { shift->rematein('make') }
10132 #-> sub CPAN::Module::test ;
10133 sub test   {
10134     my $self = shift;
10135     # $self->{badtestcnt} ||= 0;
10136     $self->rematein('test',@_);
10137 }
10138 #-> sub CPAN::Module::uptodate ;
10139 sub uptodate {
10140         my ($self) = @_;
10141         local ($_);
10142         my $inst = $self->inst_version or return undef;
10143         my $cpan = $self->cpan_version;
10144         local ($^W) = 0;
10145         CPAN::Version->vgt($cpan,$inst) and return 0;
10146     CPAN->debug(join("",
10147                 "returning uptodate. inst_file[",
10148                 $self->inst_file,
10149         "cpan[$cpan] inst[$inst]")) if $CPAN::DEBUG;
10150         return 1;
10151 }
10152 #-> sub CPAN::Module::install ;
10153 sub install {
10154     my($self) = @_;
10155     my($doit) = 0;
10156     if ($self->uptodate
10157         &&
10158         not exists $self->{force_update}
10159        ) {
10160         $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
10161                                          $self->id,
10162                                          $self->inst_version,
10163                                         ));
10164     } else {
10165         $doit = 1;
10166     }
10167     my $ro = $self->ro;
10168     if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
10169         $CPAN::Frontend->mywarn(qq{
10170 \n\n\n     ***WARNING***
10171      The module $self->{ID} has no active maintainer.\n\n\n
10172 });
10173         $CPAN::Frontend->mysleep(5);
10174     }
10175     $self->rematein('install') if $doit;
10176 }
10177 #-> sub CPAN::Module::clean ;
10178 sub clean  { shift->rematein('clean') }
10179
10180 #-> sub CPAN::Module::inst_file ;
10181 sub inst_file {
10182     my($self) = @_;
10183     $self->_file_in_path([@INC]);
10184 }
10185
10186 #-> sub CPAN::Module::available_file ;
10187 sub available_file {
10188     my($self) = @_;
10189     my $sep = $Config::Config{path_sep};
10190     my $perllib = $ENV{PERL5LIB};
10191     $perllib = $ENV{PERLLIB} unless defined $perllib;
10192     my @perllib = split(/$sep/,$perllib) if defined $perllib;
10193     $self->_file_in_path([@perllib,@INC]);
10194 }
10195
10196 #-> sub CPAN::Module::file_in_path ;
10197 sub _file_in_path {
10198     my($self,$path) = @_;
10199     my($dir,@packpath);
10200     @packpath = split /::/, $self->{ID};
10201     $packpath[-1] .= ".pm";
10202     if (@packpath == 1 && $packpath[0] eq "readline.pm") {
10203         unshift @packpath, "Term", "ReadLine"; # historical reasons
10204     }
10205     foreach $dir (@$path) {
10206         my $pmfile = File::Spec->catfile($dir,@packpath);
10207         if (-f $pmfile) {
10208             return $pmfile;
10209         }
10210     }
10211     return;
10212 }
10213
10214 #-> sub CPAN::Module::xs_file ;
10215 sub xs_file {
10216     my($self) = @_;
10217     my($dir,@packpath);
10218     @packpath = split /::/, $self->{ID};
10219     push @packpath, $packpath[-1];
10220     $packpath[-1] .= "." . $Config::Config{'dlext'};
10221     foreach $dir (@INC) {
10222         my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
10223         if (-f $xsfile) {
10224             return $xsfile;
10225         }
10226     }
10227     return;
10228 }
10229
10230 #-> sub CPAN::Module::inst_version ;
10231 sub inst_version {
10232     my($self) = @_;
10233     my $parsefile = $self->inst_file or return;
10234     my $have = $self->parse_version($parsefile);
10235     $have;
10236 }
10237
10238 #-> sub CPAN::Module::inst_version ;
10239 sub available_version {
10240     my($self) = @_;
10241     my $parsefile = $self->available_file or return;
10242     my $have = $self->parse_version($parsefile);
10243     $have;
10244 }
10245
10246 #-> sub CPAN::Module::parse_version ;
10247 sub parse_version {
10248     my($self,$parsefile) = @_;
10249     my $have = MM->parse_version($parsefile);
10250     $have = "undef" unless defined $have && length $have;
10251     $have =~ s/^ //; # since the %vd hack these two lines here are needed
10252     $have =~ s/ $//; # trailing whitespace happens all the time
10253
10254     $have = CPAN::Version->readable($have);
10255
10256     $have =~ s/\s*//g; # stringify to float around floating point issues
10257     $have; # no stringify needed, \s* above matches always
10258 }
10259
10260 #-> sub CPAN::Module::reports
10261 sub reports {
10262     my($self) = @_;
10263     $self->distribution->reports;
10264 }
10265
10266 package CPAN;
10267 use strict;
10268
10269 1;
10270
10271
10272 __END__
10273
10274 =head1 NAME
10275
10276 CPAN - query, download and build perl modules from CPAN sites
10277
10278 =head1 SYNOPSIS
10279
10280 Interactive mode:
10281
10282   perl -MCPAN -e shell
10283
10284 --or--
10285
10286   cpan
10287
10288 Basic commands:
10289
10290   # Modules:
10291
10292   cpan> install Acme::Meta                       # in the shell
10293
10294   CPAN::Shell->install("Acme::Meta");            # in perl
10295
10296   # Distributions:
10297
10298   cpan> install NWCLARK/Acme-Meta-0.02.tar.gz    # in the shell
10299
10300   CPAN::Shell->
10301     install("NWCLARK/Acme-Meta-0.02.tar.gz");    # in perl
10302
10303   # module objects:
10304
10305   $mo = CPAN::Shell->expandany($mod);
10306   $mo = CPAN::Shell->expand("Module",$mod);      # same thing
10307
10308   # distribution objects:
10309
10310   $do = CPAN::Shell->expand("Module",$mod)->distribution;
10311   $do = CPAN::Shell->expandany($distro);         # same thing
10312   $do = CPAN::Shell->expand("Distribution",
10313                             $distro);            # same thing
10314
10315 =head1 DESCRIPTION
10316
10317 The CPAN module automates or at least simplifies the make and install
10318 of perl modules and extensions. It includes some primitive searching
10319 capabilities and knows how to use Net::FTP or LWP or some external
10320 download clients to fetch the distributions from the net.
10321
10322 These are fetched from one or more of the mirrored CPAN (Comprehensive
10323 Perl Archive Network) sites and unpacked in a dedicated directory.
10324
10325 The CPAN module also supports the concept of named and versioned
10326 I<bundles> of modules. Bundles simplify the handling of sets of
10327 related modules. See Bundles below.
10328
10329 The package contains a session manager and a cache manager. The
10330 session manager keeps track of what has been fetched, built and
10331 installed in the current session. The cache manager keeps track of the
10332 disk space occupied by the make processes and deletes excess space
10333 according to a simple FIFO mechanism.
10334
10335 All methods provided are accessible in a programmer style and in an
10336 interactive shell style.
10337
10338 =head2 CPAN::shell([$prompt, $command]) Starting Interactive Mode
10339
10340 The interactive mode is entered by running
10341
10342     perl -MCPAN -e shell
10343
10344 or
10345
10346     cpan
10347
10348 which puts you into a readline interface. If C<Term::ReadKey> and
10349 either C<Term::ReadLine::Perl> or C<Term::ReadLine::Gnu> are installed
10350 it supports both history and command completion.
10351
10352 Once you are on the command line, type C<h> to get a one page help
10353 screen and the rest should be self-explanatory.
10354
10355 The function call C<shell> takes two optional arguments, one is the
10356 prompt, the second is the default initial command line (the latter
10357 only works if a real ReadLine interface module is installed).
10358
10359 The most common uses of the interactive modes are
10360
10361 =over 2
10362
10363 =item Searching for authors, bundles, distribution files and modules
10364
10365 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
10366 for each of the four categories and another, C<i> for any of the
10367 mentioned four. Each of the four entities is implemented as a class
10368 with slightly differing methods for displaying an object.
10369
10370 Arguments you pass to these commands are either strings exactly matching
10371 the identification string of an object or regular expressions that are
10372 then matched case-insensitively against various attributes of the
10373 objects. The parser recognizes a regular expression only if you
10374 enclose it between two slashes.
10375
10376 The principle is that the number of found objects influences how an
10377 item is displayed. If the search finds one item, the result is
10378 displayed with the rather verbose method C<as_string>, but if we find
10379 more than one, we display each object with the terse method
10380 C<as_glimpse>.
10381
10382 =item C<get>, C<make>, C<test>, C<install>, C<clean> modules or distributions
10383
10384 These commands take any number of arguments and investigate what is
10385 necessary to perform the action. If the argument is a distribution
10386 file name (recognized by embedded slashes), it is processed. If it is
10387 a module, CPAN determines the distribution file in which this module
10388 is included and processes that, following any dependencies named in
10389 the module's META.yml or Makefile.PL (this behavior is controlled by
10390 the configuration parameter C<prerequisites_policy>.)
10391
10392 C<get> downloads a distribution file and untars or unzips it, C<make>
10393 builds it, C<test> runs the test suite, and C<install> installs it.
10394
10395 Any C<make> or C<test> are run unconditionally. An
10396
10397   install <distribution_file>
10398
10399 also is run unconditionally. But for
10400
10401   install <module>
10402
10403 CPAN checks if an install is actually needed for it and prints
10404 I<module up to date> in the case that the distribution file containing
10405 the module doesn't need to be updated.
10406
10407 CPAN also keeps track of what it has done within the current session
10408 and doesn't try to build a package a second time regardless if it
10409 succeeded or not. It does not repeat a test run if the test
10410 has been run successfully before. Same for install runs.
10411
10412 The C<force> pragma may precede another command (currently: C<get>,
10413 C<make>, C<test>, or C<install>) and executes the command from scratch
10414 and tries to continue in case of some errors. See the section below on
10415 the C<force> and the C<fforce> pragma.
10416
10417 The C<notest> pragma may be used to skip the test part in the build
10418 process.
10419
10420 Example:
10421
10422     cpan> notest install Tk
10423
10424 A C<clean> command results in a
10425
10426   make clean
10427
10428 being executed within the distribution file's working directory.
10429
10430 =item C<readme>, C<perldoc>, C<look> module or distribution
10431
10432 C<readme> displays the README file of the associated distribution.
10433 C<Look> gets and untars (if not yet done) the distribution file,
10434 changes to the appropriate directory and opens a subshell process in
10435 that directory. C<perldoc> displays the pod documentation of the
10436 module in html or plain text format.
10437
10438 =item C<ls> author
10439
10440 =item C<ls> globbing_expression
10441
10442 The first form lists all distribution files in and below an author's
10443 CPAN directory as they are stored in the CHECKUMS files distributed on
10444 CPAN. The listing goes recursive into all subdirectories.
10445
10446 The second form allows to limit or expand the output with shell
10447 globbing as in the following examples:
10448
10449       ls JV/make*
10450       ls GSAR/*make*
10451       ls */*make*
10452
10453 The last example is very slow and outputs extra progress indicators
10454 that break the alignment of the result.
10455
10456 Note that globbing only lists directories explicitly asked for, for
10457 example FOO/* will not list FOO/bar/Acme-Sthg-n.nn.tar.gz. This may be
10458 regarded as a bug and may be changed in future versions.
10459
10460 =item C<failed>
10461
10462 The C<failed> command reports all distributions that failed on one of
10463 C<make>, C<test> or C<install> for some reason in the currently
10464 running shell session.
10465
10466 =item Persistence between sessions
10467
10468 If the C<YAML> or the C<YAML::Syck> module is installed a record of
10469 the internal state of all modules is written to disk after each step.
10470 The files contain a signature of the currently running perl version
10471 for later perusal.
10472
10473 If the configurations variable C<build_dir_reuse> is set to a true
10474 value, then CPAN.pm reads the collected YAML files. If the stored
10475 signature matches the currently running perl the stored state is
10476 loaded into memory such that effectively persistence between sessions
10477 is established.
10478
10479 =item The C<force> and the C<fforce> pragma
10480
10481 To speed things up in complex installation scenarios, CPAN.pm keeps
10482 track of what it has already done and refuses to do some things a
10483 second time. A C<get>, a C<make>, and an C<install> are not repeated.
10484 A C<test> is only repeated if the previous test was unsuccessful. The
10485 diagnostic message when CPAN.pm refuses to do something a second time
10486 is one of I<Has already been >C<unwrapped|made|tested successfully> or
10487 something similar. Another situation where CPAN refuses to act is an
10488 C<install> if the according C<test> was not successful.
10489
10490 In all these cases, the user can override the goatish behaviour by
10491 prepending the command with the word force, for example:
10492
10493   cpan> force get Foo
10494   cpan> force make AUTHOR/Bar-3.14.tar.gz
10495   cpan> force test Baz
10496   cpan> force install Acme::Meta
10497
10498 Each I<forced> command is executed with the according part of its
10499 memory erased.
10500
10501 The C<fforce> pragma is a variant that emulates a C<force get> which
10502 erases the entire memory followed by the action specified, effectively
10503 restarting the whole get/make/test/install procedure from scratch.
10504
10505 =item Lockfile
10506
10507 Interactive sessions maintain a lockfile, per default C<~/.cpan/.lock>.
10508 Batch jobs can run without a lockfile and do not disturb each other.
10509
10510 The shell offers to run in I<degraded mode> when another process is
10511 holding the lockfile. This is an experimental feature that is not yet
10512 tested very well. This second shell then does not write the history
10513 file, does not use the metadata file and has a different prompt.
10514
10515 =item Signals
10516
10517 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
10518 in the cpan-shell it is intended that you can press C<^C> anytime and
10519 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
10520 to clean up and leave the shell loop. You can emulate the effect of a
10521 SIGTERM by sending two consecutive SIGINTs, which usually means by
10522 pressing C<^C> twice.
10523
10524 CPAN.pm ignores a SIGPIPE. If the user sets C<inactivity_timeout>, a
10525 SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl
10526 Build.PL> subprocess.
10527
10528 =back
10529
10530 =head2 CPAN::Shell
10531
10532 The commands that are available in the shell interface are methods in
10533 the package CPAN::Shell. If you enter the shell command, all your
10534 input is split by the Text::ParseWords::shellwords() routine which
10535 acts like most shells do. The first word is being interpreted as the
10536 method to be called and the rest of the words are treated as arguments
10537 to this method. Continuation lines are supported if a line ends with a
10538 literal backslash.
10539
10540 =head2 autobundle
10541
10542 C<autobundle> writes a bundle file into the
10543 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
10544 a list of all modules that are both available from CPAN and currently
10545 installed within @INC. The name of the bundle file is based on the
10546 current date and a counter.
10547
10548 =head2 hosts
10549
10550 Note: this feature is still in alpha state and may change in future
10551 versions of CPAN.pm
10552
10553 This commands provides a statistical overview over recent download
10554 activities. The data for this is collected in the YAML file
10555 C<FTPstats.yml> in your C<cpan_home> directory. If no YAML module is
10556 configured or YAML not installed, then no stats are provided.
10557
10558 =head2 mkmyconfig
10559
10560 mkmyconfig() writes your own CPAN::MyConfig file into your ~/.cpan/
10561 directory so that you can save your own preferences instead of the
10562 system wide ones.
10563
10564 =head2 recent ***EXPERIMENTAL COMMAND***
10565
10566 The C<recent> command downloads a list of recent uploads to CPAN and
10567 displays them I<slowly>. While the command is running $SIG{INT} is
10568 defined to mean that the loop shall be left after having displayed the
10569 current item.
10570
10571 B<Note>: This command requires XML::LibXML installed.
10572
10573 B<Note>: This whole command currently is a bit klunky and will
10574 probably change in future versions of CPAN.pm but the general
10575 approach will likely stay.
10576
10577 B<Note>: See also L<smoke>
10578
10579 =head2 recompile
10580
10581 recompile() is a very special command in that it takes no argument and
10582 runs the make/test/install cycle with brute force over all installed
10583 dynamically loadable extensions (aka XS modules) with 'force' in
10584 effect. The primary purpose of this command is to finish a network
10585 installation. Imagine, you have a common source tree for two different
10586 architectures. You decide to do a completely independent fresh
10587 installation. You start on one architecture with the help of a Bundle
10588 file produced earlier. CPAN installs the whole Bundle for you, but
10589 when you try to repeat the job on the second architecture, CPAN
10590 responds with a C<"Foo up to date"> message for all modules. So you
10591 invoke CPAN's recompile on the second architecture and you're done.
10592
10593 Another popular use for C<recompile> is to act as a rescue in case your
10594 perl breaks binary compatibility. If one of the modules that CPAN uses
10595 is in turn depending on binary compatibility (so you cannot run CPAN
10596 commands), then you should try the CPAN::Nox module for recovery.
10597
10598 =head2 report Bundle|Distribution|Module
10599
10600 The C<report> command temporarily turns on the C<test_report> config
10601 variable, then runs the C<force test> command with the given
10602 arguments. The C<force> pragma is used to re-run the tests and repeat
10603 every step that might have failed before.
10604
10605 =head2 smoke ***EXPERIMENTAL COMMAND***
10606
10607 B<*** WARNING: this command downloads and executes software from CPAN to
10608 your computer of completely unknown status. You should never do
10609 this with your normal account and better have a dedicated well
10610 separated and secured machine to do this. ***>
10611
10612 The C<smoke> command takes the list of recent uploads to CPAN as
10613 provided by the C<recent> command and tests them all. While the
10614 command is running $SIG{INT} is defined to mean that the current item
10615 shall be skipped.
10616
10617 B<Note>: This whole command currently is a bit klunky and will
10618 probably change in future versions of CPAN.pm but the general
10619 approach will likely stay.
10620
10621 B<Note>: See also L<recent>
10622
10623 =head2 upgrade [Module|/Regex/]...
10624
10625 The C<upgrade> command first runs an C<r> command with the given
10626 arguments and then installs the newest versions of all modules that
10627 were listed by that.
10628
10629 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
10630
10631 Although it may be considered internal, the class hierarchy does matter
10632 for both users and programmer. CPAN.pm deals with above mentioned four
10633 classes, and all those classes share a set of methods. A classical
10634 single polymorphism is in effect. A metaclass object registers all
10635 objects of all kinds and indexes them with a string. The strings
10636 referencing objects have a separated namespace (well, not completely
10637 separated):
10638
10639          Namespace                         Class
10640
10641    words containing a "/" (slash)      Distribution
10642     words starting with Bundle::          Bundle
10643           everything else            Module or Author
10644
10645 Modules know their associated Distribution objects. They always refer
10646 to the most recent official release. Developers may mark their releases
10647 as unstable development versions (by inserting an underbar into the
10648 module version number which will also be reflected in the distribution
10649 name when you run 'make dist'), so the really hottest and newest
10650 distribution is not always the default.  If a module Foo circulates
10651 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
10652 way to install version 1.23 by saying
10653
10654     install Foo
10655
10656 This would install the complete distribution file (say
10657 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
10658 like to install version 1.23_90, you need to know where the
10659 distribution file resides on CPAN relative to the authors/id/
10660 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
10661 so you would have to say
10662
10663     install BAR/Foo-1.23_90.tar.gz
10664
10665 The first example will be driven by an object of the class
10666 CPAN::Module, the second by an object of class CPAN::Distribution.
10667
10668 =head2 Integrating local directories
10669
10670 Note: this feature is still in alpha state and may change in future
10671 versions of CPAN.pm
10672
10673 Distribution objects are normally distributions from the CPAN, but
10674 there is a slightly degenerate case for Distribution objects, too, of
10675 projects held on the local disk. These distribution objects have the
10676 same name as the local directory and end with a dot. A dot by itself
10677 is also allowed for the current directory at the time CPAN.pm was
10678 used. All actions such as C<make>, C<test>, and C<install> are applied
10679 directly to that directory. This gives the command C<cpan .> an
10680 interesting touch: while the normal mantra of installing a CPAN module
10681 without CPAN.pm is one of
10682
10683     perl Makefile.PL                 perl Build.PL
10684            ( go and get prerequisites )
10685     make                             ./Build
10686     make test                        ./Build test
10687     make install                     ./Build install
10688
10689 the command C<cpan .> does all of this at once. It figures out which
10690 of the two mantras is appropriate, fetches and installs all
10691 prerequisites, cares for them recursively and finally finishes the
10692 installation of the module in the current directory, be it a CPAN
10693 module or not.
10694
10695 The typical usage case is for private modules or working copies of
10696 projects from remote repositories on the local disk.
10697
10698 =head1 CONFIGURATION
10699
10700 When the CPAN module is used for the first time, a configuration
10701 dialog tries to determine a couple of site specific options. The
10702 result of the dialog is stored in a hash reference C< $CPAN::Config >
10703 in a file CPAN/Config.pm.
10704
10705 The default values defined in the CPAN/Config.pm file can be
10706 overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
10707 best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
10708 added to the search path of the CPAN module before the use() or
10709 require() statements. The mkmyconfig command writes this file for you.
10710
10711 The C<o conf> command has various bells and whistles:
10712
10713 =over
10714
10715 =item completion support
10716
10717 If you have a ReadLine module installed, you can hit TAB at any point
10718 of the commandline and C<o conf> will offer you completion for the
10719 built-in subcommands and/or config variable names.
10720
10721 =item displaying some help: o conf help
10722
10723 Displays a short help
10724
10725 =item displaying current values: o conf [KEY]
10726
10727 Displays the current value(s) for this config variable. Without KEY
10728 displays all subcommands and config variables.
10729
10730 Example:
10731
10732   o conf shell
10733
10734 If KEY starts and ends with a slash the string in between is
10735 interpreted as a regular expression and only keys matching this regex
10736 are displayed
10737
10738 Example:
10739
10740   o conf /color/
10741
10742 =item changing of scalar values: o conf KEY VALUE
10743
10744 Sets the config variable KEY to VALUE. The empty string can be
10745 specified as usual in shells, with C<''> or C<"">
10746
10747 Example:
10748
10749   o conf wget /usr/bin/wget
10750
10751 =item changing of list values: o conf KEY SHIFT|UNSHIFT|PUSH|POP|SPLICE|LIST
10752
10753 If a config variable name ends with C<list>, it is a list. C<o conf
10754 KEY shift> removes the first element of the list, C<o conf KEY pop>
10755 removes the last element of the list. C<o conf KEYS unshift LIST>
10756 prepends a list of values to the list, C<o conf KEYS push LIST>
10757 appends a list of valued to the list.
10758
10759 Likewise, C<o conf KEY splice LIST> passes the LIST to the according
10760 splice command.
10761
10762 Finally, any other list of arguments is taken as a new list value for
10763 the KEY variable discarding the previous value.
10764
10765 Examples:
10766
10767   o conf urllist unshift http://cpan.dev.local/CPAN
10768   o conf urllist splice 3 1
10769   o conf urllist http://cpan1.local http://cpan2.local ftp://ftp.perl.org
10770
10771 =item reverting to saved: o conf defaults
10772
10773 Reverts all config variables to the state in the saved config file.
10774
10775 =item saving the config: o conf commit
10776
10777 Saves all config variables to the current config file (CPAN/Config.pm
10778 or CPAN/MyConfig.pm that was loaded at start).
10779
10780 =back
10781
10782 The configuration dialog can be started any time later again by
10783 issuing the command C< o conf init > in the CPAN shell. A subset of
10784 the configuration dialog can be run by issuing C<o conf init WORD>
10785 where WORD is any valid config variable or a regular expression.
10786
10787 =head2 Config Variables
10788
10789 Currently the following keys in the hash reference $CPAN::Config are
10790 defined:
10791
10792   applypatch         path to external prg
10793   auto_commit        commit all changes to config variables to disk
10794   build_cache        size of cache for directories to build modules
10795   build_dir          locally accessible directory to build modules
10796   build_dir_reuse    boolean if distros in build_dir are persistent
10797   build_requires_install_policy
10798                      to install or not to install when a module is
10799                      only needed for building. yes|no|ask/yes|ask/no
10800   bzip2              path to external prg
10801   cache_metadata     use serializer to cache metadata
10802   commands_quote     prefered character to use for quoting external
10803                      commands when running them. Defaults to double
10804                      quote on Windows, single tick everywhere else;
10805                      can be set to space to disable quoting
10806   check_sigs         if signatures should be verified
10807   colorize_debug     Term::ANSIColor attributes for debugging output
10808   colorize_output    boolean if Term::ANSIColor should colorize output
10809   colorize_print     Term::ANSIColor attributes for normal output
10810   colorize_warn      Term::ANSIColor attributes for warnings
10811   commandnumber_in_prompt
10812                      boolean if you want to see current command number
10813   cpan_home          local directory reserved for this package
10814   curl               path to external prg
10815   dontload_hash      DEPRECATED
10816   dontload_list      arrayref: modules in the list will not be
10817                      loaded by the CPAN::has_inst() routine
10818   ftp                path to external prg
10819   ftp_passive        if set, the envariable FTP_PASSIVE is set for downloads
10820   ftp_proxy          proxy host for ftp requests
10821   getcwd             see below
10822   gpg                path to external prg
10823   gzip               location of external program gzip
10824   histfile           file to maintain history between sessions
10825   histsize           maximum number of lines to keep in histfile
10826   http_proxy         proxy host for http requests
10827   inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
10828                      after this many seconds inactivity. Set to 0 to
10829                      never break.
10830   index_expire       after this many days refetch index files
10831   inhibit_startup_message
10832                      if true, does not print the startup message
10833   keep_source_where  directory in which to keep the source (if we do)
10834   load_module_verbosity
10835                      report loading of optional modules used by CPAN.pm
10836   lynx               path to external prg
10837   make               location of external make program
10838   make_arg           arguments that should always be passed to 'make'
10839   make_install_make_command
10840                      the make command for running 'make install', for
10841                      example 'sudo make'
10842   make_install_arg   same as make_arg for 'make install'
10843   makepl_arg         arguments passed to 'perl Makefile.PL'
10844   mbuild_arg         arguments passed to './Build'
10845   mbuild_install_arg arguments passed to './Build install'
10846   mbuild_install_build_command
10847                      command to use instead of './Build' when we are
10848                      in the install stage, for example 'sudo ./Build'
10849   mbuildpl_arg       arguments passed to 'perl Build.PL'
10850   ncftp              path to external prg
10851   ncftpget           path to external prg
10852   no_proxy           don't proxy to these hosts/domains (comma separated list)
10853   pager              location of external program more (or any pager)
10854   password           your password if you CPAN server wants one
10855   patch              path to external prg
10856   prefer_installer   legal values are MB and EUMM: if a module comes
10857                      with both a Makefile.PL and a Build.PL, use the
10858                      former (EUMM) or the latter (MB); if the module
10859                      comes with only one of the two, that one will be
10860                      used in any case
10861   prerequisites_policy
10862                      what to do if you are missing module prerequisites
10863                      ('follow' automatically, 'ask' me, or 'ignore')
10864   prefs_dir          local directory to store per-distro build options
10865   proxy_user         username for accessing an authenticating proxy
10866   proxy_pass         password for accessing an authenticating proxy
10867   randomize_urllist  add some randomness to the sequence of the urllist
10868   scan_cache         controls scanning of cache ('atstart' or 'never')
10869   shell              your favorite shell
10870   show_unparsable_versions
10871                      boolean if r command tells which modules are versionless
10872   show_upload_date   boolean if commands should try to determine upload date
10873   show_zero_versions boolean if r command tells for which modules $version==0
10874   tar                location of external program tar
10875   tar_verbosity      verbosity level for the tar command
10876   term_is_latin      deprecated: if true Unicode is translated to ISO-8859-1
10877                      (and nonsense for characters outside latin range)
10878   term_ornaments     boolean to turn ReadLine ornamenting on/off
10879   test_report        email test reports (if CPAN::Reporter is installed)
10880   unzip              location of external program unzip
10881   urllist            arrayref to nearby CPAN sites (or equivalent locations)
10882   use_sqlite         use CPAN::SQLite for metadata storage (fast and lean)
10883   username           your username if you CPAN server wants one
10884   wait_list          arrayref to a wait server to try (See CPAN::WAIT)
10885   wget               path to external prg
10886   yaml_load_code     enable YAML code deserialisation
10887   yaml_module        which module to use to read/write YAML files
10888
10889 You can set and query each of these options interactively in the cpan
10890 shell with the C<o conf> or the C<o conf init> command as specified below.
10891
10892 =over 2
10893
10894 =item C<o conf E<lt>scalar optionE<gt>>
10895
10896 prints the current value of the I<scalar option>
10897
10898 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
10899
10900 Sets the value of the I<scalar option> to I<value>
10901
10902 =item C<o conf E<lt>list optionE<gt>>
10903
10904 prints the current value of the I<list option> in MakeMaker's
10905 neatvalue format.
10906
10907 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
10908
10909 shifts or pops the array in the I<list option> variable
10910
10911 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
10912
10913 works like the corresponding perl commands.
10914
10915 =item interactive editing: o conf init [MATCH|LIST]
10916
10917 Runs an interactive configuration dialog for matching variables.
10918 Without argument runs the dialog over all supported config variables.
10919 To specify a MATCH the argument must be enclosed by slashes.
10920
10921 Examples:
10922
10923   o conf init ftp_passive ftp_proxy
10924   o conf init /color/
10925
10926 Note: this method of setting config variables often provides more
10927 explanation about the functioning of a variable than the manpage.
10928
10929 =back
10930
10931 =head2 CPAN::anycwd($path): Note on config variable getcwd
10932
10933 CPAN.pm changes the current working directory often and needs to
10934 determine its own current working directory. Per default it uses
10935 Cwd::cwd but if this doesn't work on your system for some reason,
10936 alternatives can be configured according to the following table:
10937
10938 =over 4
10939
10940 =item cwd
10941
10942 Calls Cwd::cwd
10943
10944 =item getcwd
10945
10946 Calls Cwd::getcwd
10947
10948 =item fastcwd
10949
10950 Calls Cwd::fastcwd
10951
10952 =item backtickcwd
10953
10954 Calls the external command cwd.
10955
10956 =back
10957
10958 =head2 Note on the format of the urllist parameter
10959
10960 urllist parameters are URLs according to RFC 1738. We do a little
10961 guessing if your URL is not compliant, but if you have problems with
10962 C<file> URLs, please try the correct format. Either:
10963
10964     file://localhost/whatever/ftp/pub/CPAN/
10965
10966 or
10967
10968     file:///home/ftp/pub/CPAN/
10969
10970 =head2 The urllist parameter has CD-ROM support
10971
10972 The C<urllist> parameter of the configuration table contains a list of
10973 URLs that are to be used for downloading. If the list contains any
10974 C<file> URLs, CPAN always tries to get files from there first. This
10975 feature is disabled for index files. So the recommendation for the
10976 owner of a CD-ROM with CPAN contents is: include your local, possibly
10977 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
10978
10979   o conf urllist push file://localhost/CDROM/CPAN
10980
10981 CPAN.pm will then fetch the index files from one of the CPAN sites
10982 that come at the beginning of urllist. It will later check for each
10983 module if there is a local copy of the most recent version.
10984
10985 Another peculiarity of urllist is that the site that we could
10986 successfully fetch the last file from automatically gets a preference
10987 token and is tried as the first site for the next request. So if you
10988 add a new site at runtime it may happen that the previously preferred
10989 site will be tried another time. This means that if you want to disallow
10990 a site for the next transfer, it must be explicitly removed from
10991 urllist.
10992
10993 =head2 Maintaining the urllist parameter
10994
10995 If you have YAML.pm (or some other YAML module configured in
10996 C<yaml_module>) installed, CPAN.pm collects a few statistical data
10997 about recent downloads. You can view the statistics with the C<hosts>
10998 command or inspect them directly by looking into the C<FTPstats.yml>
10999 file in your C<cpan_home> directory.
11000
11001 To get some interesting statistics it is recommended to set the
11002 C<randomize_urllist> parameter that introduces some amount of
11003 randomness into the URL selection.
11004
11005 =head2 The C<requires> and C<build_requires> dependency declarations
11006
11007 Since CPAN.pm version 1.88_51 modules declared as C<build_requires> by
11008 a distribution are treated differently depending on the config
11009 variable C<build_requires_install_policy>. By setting
11010 C<build_requires_install_policy> to C<no> such a module is not being
11011 installed. It is only built and tested and then kept in the list of
11012 tested but uninstalled modules. As such it is available during the
11013 build of the dependent module by integrating the path to the
11014 C<blib/arch> and C<blib/lib> directories in the environment variable
11015 PERL5LIB. If C<build_requires_install_policy> is set ti C<yes>, then
11016 both modules declared as C<requires> and those declared as
11017 C<build_requires> are treated alike. By setting to C<ask/yes> or
11018 C<ask/no>, CPAN.pm asks the user and sets the default accordingly.
11019
11020 =head2 Configuration for individual distributions (I<Distroprefs>)
11021
11022 (B<Note:> This feature has been introduced in CPAN.pm 1.8854 and is
11023 still considered beta quality)
11024
11025 Distributions on the CPAN usually behave according to what we call the
11026 CPAN mantra. Or since the event of Module::Build we should talk about
11027 two mantras:
11028
11029     perl Makefile.PL     perl Build.PL
11030     make                 ./Build
11031     make test            ./Build test
11032     make install         ./Build install
11033
11034 But some modules cannot be built with this mantra. They try to get
11035 some extra data from the user via the environment, extra arguments or
11036 interactively thus disturbing the installation of large bundles like
11037 Phalanx100 or modules with many dependencies like Plagger.
11038
11039 The distroprefs system of C<CPAN.pm> addresses this problem by
11040 allowing the user to specify extra informations and recipes in YAML
11041 files to either
11042
11043 =over
11044
11045 =item
11046
11047 pass additional arguments to one of the four commands,
11048
11049 =item
11050
11051 set environment variables
11052
11053 =item
11054
11055 instantiate an Expect object that reads from the console, waits for
11056 some regular expressions and enters some answers
11057
11058 =item
11059
11060 temporarily override assorted C<CPAN.pm> configuration variables
11061
11062 =item
11063
11064 specify dependencies that the original maintainer forgot to specify
11065
11066 =item
11067
11068 disable the installation of an object altogether
11069
11070 =back
11071
11072 See the YAML and Data::Dumper files that come with the C<CPAN.pm>
11073 distribution in the C<distroprefs/> directory for examples.
11074
11075 =head2 Filenames
11076
11077 The YAML files themselves must have the C<.yml> extension, all other
11078 files are ignored (for two exceptions see I<Fallback Data::Dumper and
11079 Storable> below). The containing directory can be specified in
11080 C<CPAN.pm> in the C<prefs_dir> config variable. Try C<o conf init
11081 prefs_dir> in the CPAN shell to set and activate the distroprefs
11082 system.
11083
11084 Every YAML file may contain arbitrary documents according to the YAML
11085 specification and every single document is treated as an entity that
11086 can specify the treatment of a single distribution.
11087
11088 The names of the files can be picked freely, C<CPAN.pm> always reads
11089 all files (in alphabetical order) and takes the key C<match> (see
11090 below in I<Language Specs>) as a hashref containing match criteria
11091 that determine if the current distribution matches the YAML document
11092 or not.
11093
11094 =head2 Fallback Data::Dumper and Storable
11095
11096 If neither your configured C<yaml_module> nor YAML.pm is installed
11097 CPAN.pm falls back to using Data::Dumper and Storable and looks for
11098 files with the extensions C<.dd> or C<.st> in the C<prefs_dir>
11099 directory. These files are expected to contain one or more hashrefs.
11100 For Data::Dumper generated files, this is expected to be done with by
11101 defining C<$VAR1>, C<$VAR2>, etc. The YAML shell would produce these
11102 with the command
11103
11104     ysh < somefile.yml > somefile.dd
11105
11106 For Storable files the rule is that they must be constructed such that
11107 C<Storable::retrieve(file)> returns an array reference and the array
11108 elements represent one distropref object each. The conversion from
11109 YAML would look like so:
11110
11111     perl -MYAML=LoadFile -MStorable=nstore -e '
11112         @y=LoadFile(shift);
11113         nstore(\@y, shift)' somefile.yml somefile.st
11114
11115 In bootstrapping situations it is usually sufficient to translate only
11116 a few YAML files to Data::Dumper for the crucial modules like
11117 C<YAML::Syck>, C<YAML.pm> and C<Expect.pm>. If you prefer Storable
11118 over Data::Dumper, remember to pull out a Storable version that writes
11119 an older format than all the other Storable versions that will need to
11120 read them.
11121
11122 =head2 Blueprint
11123
11124 The following example contains all supported keywords and structures
11125 with the exception of C<eexpect> which can be used instead of
11126 C<expect>.
11127
11128   ---
11129   comment: "Demo"
11130   match:
11131     module: "Dancing::Queen"
11132     distribution: "^CHACHACHA/Dancing-"
11133     perl: "/usr/local/cariba-perl/bin/perl"
11134     perlconfig:
11135       archname: "freebsd"
11136   disabled: 1
11137   cpanconfig:
11138     make: gmake
11139   pl:
11140     args:
11141       - "--somearg=specialcase"
11142
11143     env: {}
11144
11145     expect:
11146       - "Which is your favorite fruit"
11147       - "apple\n"
11148
11149   make:
11150     args:
11151       - all
11152       - extra-all
11153
11154     env: {}
11155
11156     expect: []
11157
11158     commendline: "echo SKIPPING make"
11159
11160   test:
11161     args: []
11162
11163     env: {}
11164
11165     expect: []
11166
11167   install:
11168     args: []
11169
11170     env:
11171       WANT_TO_INSTALL: YES
11172
11173     expect:
11174       - "Do you really want to install"
11175       - "y\n"
11176
11177   patches:
11178     - "ABCDE/Fedcba-3.14-ABCDE-01.patch"
11179
11180   depends:
11181     configure_requires:
11182       LWP: 5.8
11183     build_requires:
11184       Test::Exception: 0.25
11185     requires:
11186       Spiffy: 0.30
11187
11188
11189 =head2 Language Specs
11190
11191 Every YAML document represents a single hash reference. The valid keys
11192 in this hash are as follows:
11193
11194 =over
11195
11196 =item comment [scalar]
11197
11198 A comment
11199
11200 =item cpanconfig [hash]
11201
11202 Temporarily override assorted C<CPAN.pm> configuration variables.
11203
11204 Supported are: C<build_requires_install_policy>, C<check_sigs>,
11205 C<make>, C<make_install_make_command>, C<prefer_installer>,
11206 C<test_report>. Please report as a bug when you need another one
11207 supported.
11208
11209 =item depends [hash] *** EXPERIMENTAL FEATURE ***
11210
11211 All three types, namely C<configure_requires>, C<build_requires>, and
11212 C<requires> are supported in the way specified in the META.yml
11213 specification. The current implementation I<merges> the specified
11214 dependencies with those declared by the package maintainer. In a
11215 future implementation this may be changed to override the original
11216 declaration.
11217
11218 =item disabled [boolean]
11219
11220 Specifies that this distribution shall not be processed at all.
11221
11222 =item goto [string]
11223
11224 The canonical name of a delegate distribution that shall be installed
11225 instead. Useful when a new version, although it tests OK itself,
11226 breaks something else or a developer release or a fork is already
11227 uploaded that is better than the last released version.
11228
11229 =item install [hash]
11230
11231 Processing instructions for the C<make install> or C<./Build install>
11232 phase of the CPAN mantra. See below under I<Processiong Instructions>.
11233
11234 =item make [hash]
11235
11236 Processing instructions for the C<make> or C<./Build> phase of the
11237 CPAN mantra. See below under I<Processiong Instructions>.
11238
11239 =item match [hash]
11240
11241 A hashref with one or more of the keys C<distribution>, C<modules>,
11242 C<perl>, and C<perlconfig> that specify if a document is targeted at a
11243 specific CPAN distribution or installation.
11244
11245 The corresponding values are interpreted as regular expressions. The
11246 C<distribution> related one will be matched against the canonical
11247 distribution name, e.g. "AUTHOR/Foo-Bar-3.14.tar.gz".
11248
11249 The C<module> related one will be matched against I<all> modules
11250 contained in the distribution until one module matches.
11251
11252 The C<perl> related one will be matched against C<$^X> (but with the
11253 absolute path).
11254
11255 The value associated with C<perlconfig> is itself a hashref that is
11256 matched against corresponding values in the C<%Config::Config> hash
11257 living in the C< Config.pm > module.
11258
11259 If more than one restriction of C<module>, C<distribution>, and
11260 C<perl> is specified, the results of the separately computed match
11261 values must all match. If this is the case then the hashref
11262 represented by the YAML document is returned as the preference
11263 structure for the current distribution.
11264
11265 =item patches [array]
11266
11267 An array of patches on CPAN or on the local disk to be applied in
11268 order via the external patch program. If the value for the C<-p>
11269 parameter is C<0> or C<1> is determined by reading the patch
11270 beforehand.
11271
11272 Note: if the C<applypatch> program is installed and C<CPAN::Config>
11273 knows about it B<and> a patch is written by the C<makepatch> program,
11274 then C<CPAN.pm> lets C<applypatch> apply the patch. Both C<makepatch>
11275 and C<applypatch> are available from CPAN in the C<JV/makepatch-*>
11276 distribution.
11277
11278 =item pl [hash]
11279
11280 Processing instructions for the C<perl Makefile.PL> or C<perl
11281 Build.PL> phase of the CPAN mantra. See below under I<Processiong
11282 Instructions>.
11283
11284 =item test [hash]
11285
11286 Processing instructions for the C<make test> or C<./Build test> phase
11287 of the CPAN mantra. See below under I<Processiong Instructions>.
11288
11289 =back
11290
11291 =head2 Processing Instructions
11292
11293 =over
11294
11295 =item args [array]
11296
11297 Arguments to be added to the command line
11298
11299 =item commandline
11300
11301 A full commandline that will be executed as it stands by a system
11302 call. During the execution the environment variable PERL will is set
11303 to $^X (but with an absolute path). If C<commandline> is specified,
11304 the content of C<args> is not used.
11305
11306 =item eexpect [hash]
11307
11308 Extended C<expect>. This is a hash reference with four allowed keys,
11309 C<mode>, C<timeout>, C<reuse>, and C<talk>.
11310
11311 C<mode> may have the values C<deterministic> for the case where all
11312 questions come in the order written down and C<anyorder> for the case
11313 where the questions may come in any order. The default mode is
11314 C<deterministic>.
11315
11316 C<timeout> denotes a timeout in seconds. Floating point timeouts are
11317 OK. In the case of a C<mode=deterministic> the timeout denotes the
11318 timeout per question, in the case of C<mode=anyorder> it denotes the
11319 timeout per byte received from the stream or questions.
11320
11321 C<talk> is a reference to an array that contains alternating questions
11322 and answers. Questions are regular expressions and answers are literal
11323 strings. The Expect module will then watch the stream coming from the
11324 execution of the external program (C<perl Makefile.PL>, C<perl
11325 Build.PL>, C<make>, etc.).
11326
11327 In the case of C<mode=deterministic> the CPAN.pm will inject the
11328 according answer as soon as the stream matches the regular expression.
11329
11330 In the case of C<mode=anyorder> CPAN.pm will answer a question as soon
11331 as the timeout is reached for the next byte in the input stream. In
11332 this mode you can use the C<reuse> parameter to decide what shall
11333 happen with a question-answer pair after it has been used. In the
11334 default case (reuse=0) it is removed from the array, so it cannot be
11335 used again accidentally. In this case, if you want to answer the
11336 question C<Do you really want to do that> several times, then it must
11337 be included in the array at least as often as you want this answer to
11338 be given. Setting the parameter C<reuse> to 1 makes this repetition
11339 unnecessary.
11340
11341 =item env [hash]
11342
11343 Environment variables to be set during the command
11344
11345 =item expect [array]
11346
11347 C<< expect: <array> >> is a short notation for
11348
11349   eexpect:
11350     mode: deterministic
11351     timeout: 15
11352     talk: <array>
11353
11354 =back
11355
11356 =head2 Schema verification with C<Kwalify>
11357
11358 If you have the C<Kwalify> module installed (which is part of the
11359 Bundle::CPANxxl), then all your distroprefs files are checked for
11360 syntactical correctness.
11361
11362 =head2 Example Distroprefs Files
11363
11364 C<CPAN.pm> comes with a collection of example YAML files. Note that these
11365 are really just examples and should not be used without care because
11366 they cannot fit everybody's purpose. After all the authors of the
11367 packages that ask questions had a need to ask, so you should watch
11368 their questions and adjust the examples to your environment and your
11369 needs. You have beend warned:-)
11370
11371 =head1 PROGRAMMER'S INTERFACE
11372
11373 If you do not enter the shell, the available shell commands are both
11374 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
11375 functions in the calling package (C<install(...)>).  Before calling low-level
11376 commands it makes sense to initialize components of CPAN you need, e.g.:
11377
11378   CPAN::HandleConfig->load;
11379   CPAN::Shell::setup_output;
11380   CPAN::Index->reload;
11381
11382 High-level commands do such initializations automatically.
11383
11384 There's currently only one class that has a stable interface -
11385 CPAN::Shell. All commands that are available in the CPAN shell are
11386 methods of the class CPAN::Shell. Each of the commands that produce
11387 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
11388 the IDs of all modules within the list.
11389
11390 =over 2
11391
11392 =item expand($type,@things)
11393
11394 The IDs of all objects available within a program are strings that can
11395 be expanded to the corresponding real objects with the
11396 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
11397 list of CPAN::Module objects according to the C<@things> arguments
11398 given. In scalar context it only returns the first element of the
11399 list.
11400
11401 =item expandany(@things)
11402
11403 Like expand, but returns objects of the appropriate type, i.e.
11404 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
11405 CPAN::Distribution objects for distributions. Note: it does not expand
11406 to CPAN::Author objects.
11407
11408 =item Programming Examples
11409
11410 This enables the programmer to do operations that combine
11411 functionalities that are available in the shell.
11412
11413     # install everything that is outdated on my disk:
11414     perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
11415
11416     # install my favorite programs if necessary:
11417     for $mod (qw(Net::FTP Digest::SHA Data::Dumper)) {
11418         CPAN::Shell->install($mod);
11419     }
11420
11421     # list all modules on my disk that have no VERSION number
11422     for $mod (CPAN::Shell->expand("Module","/./")) {
11423         next unless $mod->inst_file;
11424         # MakeMaker convention for undefined $VERSION:
11425         next unless $mod->inst_version eq "undef";
11426         print "No VERSION in ", $mod->id, "\n";
11427     }
11428
11429     # find out which distribution on CPAN contains a module:
11430     print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
11431
11432 Or if you want to write a cronjob to watch The CPAN, you could list
11433 all modules that need updating. First a quick and dirty way:
11434
11435     perl -e 'use CPAN; CPAN::Shell->r;'
11436
11437 If you don't want to get any output in the case that all modules are
11438 up to date, you can parse the output of above command for the regular
11439 expression //modules are up to date// and decide to mail the output
11440 only if it doesn't match. Ick?
11441
11442 If you prefer to do it more in a programmer style in one single
11443 process, maybe something like this suits you better:
11444
11445   # list all modules on my disk that have newer versions on CPAN
11446   for $mod (CPAN::Shell->expand("Module","/./")) {
11447     next unless $mod->inst_file;
11448     next if $mod->uptodate;
11449     printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
11450         $mod->id, $mod->inst_version, $mod->cpan_version;
11451   }
11452
11453 If that gives you too much output every day, you maybe only want to
11454 watch for three modules. You can write
11455
11456   for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")) {
11457
11458 as the first line instead. Or you can combine some of the above
11459 tricks:
11460
11461   # watch only for a new mod_perl module
11462   $mod = CPAN::Shell->expand("Module","mod_perl");
11463   exit if $mod->uptodate;
11464   # new mod_perl arrived, let me know all update recommendations
11465   CPAN::Shell->r;
11466
11467 =back
11468
11469 =head2 Methods in the other Classes
11470
11471 =over 4
11472
11473 =item CPAN::Author::as_glimpse()
11474
11475 Returns a one-line description of the author
11476
11477 =item CPAN::Author::as_string()
11478
11479 Returns a multi-line description of the author
11480
11481 =item CPAN::Author::email()
11482
11483 Returns the author's email address
11484
11485 =item CPAN::Author::fullname()
11486
11487 Returns the author's name
11488
11489 =item CPAN::Author::name()
11490
11491 An alias for fullname
11492
11493 =item CPAN::Bundle::as_glimpse()
11494
11495 Returns a one-line description of the bundle
11496
11497 =item CPAN::Bundle::as_string()
11498
11499 Returns a multi-line description of the bundle
11500
11501 =item CPAN::Bundle::clean()
11502
11503 Recursively runs the C<clean> method on all items contained in the bundle.
11504
11505 =item CPAN::Bundle::contains()
11506
11507 Returns a list of objects' IDs contained in a bundle. The associated
11508 objects may be bundles, modules or distributions.
11509
11510 =item CPAN::Bundle::force($method,@args)
11511
11512 Forces CPAN to perform a task that it normally would have refused to
11513 do. Force takes as arguments a method name to be called and any number
11514 of additional arguments that should be passed to the called method.
11515 The internals of the object get the needed changes so that CPAN.pm
11516 does not refuse to take the action. The C<force> is passed recursively
11517 to all contained objects. See also the section above on the C<force>
11518 and the C<fforce> pragma.
11519
11520 =item CPAN::Bundle::get()
11521
11522 Recursively runs the C<get> method on all items contained in the bundle
11523
11524 =item CPAN::Bundle::inst_file()
11525
11526 Returns the highest installed version of the bundle in either @INC or
11527 C<$CPAN::Config->{cpan_home}>. Note that this is different from
11528 CPAN::Module::inst_file.
11529
11530 =item CPAN::Bundle::inst_version()
11531
11532 Like CPAN::Bundle::inst_file, but returns the $VERSION
11533
11534 =item CPAN::Bundle::uptodate()
11535
11536 Returns 1 if the bundle itself and all its members are uptodate.
11537
11538 =item CPAN::Bundle::install()
11539
11540 Recursively runs the C<install> method on all items contained in the bundle
11541
11542 =item CPAN::Bundle::make()
11543
11544 Recursively runs the C<make> method on all items contained in the bundle
11545
11546 =item CPAN::Bundle::readme()
11547
11548 Recursively runs the C<readme> method on all items contained in the bundle
11549
11550 =item CPAN::Bundle::test()
11551
11552 Recursively runs the C<test> method on all items contained in the bundle
11553
11554 =item CPAN::Distribution::as_glimpse()
11555
11556 Returns a one-line description of the distribution
11557
11558 =item CPAN::Distribution::as_string()
11559
11560 Returns a multi-line description of the distribution
11561
11562 =item CPAN::Distribution::author
11563
11564 Returns the CPAN::Author object of the maintainer who uploaded this
11565 distribution
11566
11567 =item CPAN::Distribution::pretty_id()
11568
11569 Returns a string of the form "AUTHORID/TARBALL", where AUTHORID is the
11570 author's PAUSE ID and TARBALL is the distribution filename.
11571
11572 =item CPAN::Distribution::base_id()
11573
11574 Returns the distribution filename without any archive suffix.  E.g
11575 "Foo-Bar-0.01"
11576
11577 =item CPAN::Distribution::clean()
11578
11579 Changes to the directory where the distribution has been unpacked and
11580 runs C<make clean> there.
11581
11582 =item CPAN::Distribution::containsmods()
11583
11584 Returns a list of IDs of modules contained in a distribution file.
11585 Only works for distributions listed in the 02packages.details.txt.gz
11586 file. This typically means that only the most recent version of a
11587 distribution is covered.
11588
11589 =item CPAN::Distribution::cvs_import()
11590
11591 Changes to the directory where the distribution has been unpacked and
11592 runs something like
11593
11594     cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
11595
11596 there.
11597
11598 =item CPAN::Distribution::dir()
11599
11600 Returns the directory into which this distribution has been unpacked.
11601
11602 =item CPAN::Distribution::force($method,@args)
11603
11604 Forces CPAN to perform a task that it normally would have refused to
11605 do. Force takes as arguments a method name to be called and any number
11606 of additional arguments that should be passed to the called method.
11607 The internals of the object get the needed changes so that CPAN.pm
11608 does not refuse to take the action. See also the section above on the
11609 C<force> and the C<fforce> pragma.
11610
11611 =item CPAN::Distribution::get()
11612
11613 Downloads the distribution from CPAN and unpacks it. Does nothing if
11614 the distribution has already been downloaded and unpacked within the
11615 current session.
11616
11617 =item CPAN::Distribution::install()
11618
11619 Changes to the directory where the distribution has been unpacked and
11620 runs the external command C<make install> there. If C<make> has not
11621 yet been run, it will be run first. A C<make test> will be issued in
11622 any case and if this fails, the install will be canceled. The
11623 cancellation can be avoided by letting C<force> run the C<install> for
11624 you.
11625
11626 This install method has only the power to install the distribution if
11627 there are no dependencies in the way. To install an object and all of
11628 its dependencies, use CPAN::Shell->install.
11629
11630 Note that install() gives no meaningful return value. See uptodate().
11631
11632 =item CPAN::Distribution::install_tested()
11633
11634 Install all the distributions that have been tested sucessfully but
11635 not yet installed. See also C<is_tested>.
11636
11637 =item CPAN::Distribution::isa_perl()
11638
11639 Returns 1 if this distribution file seems to be a perl distribution.
11640 Normally this is derived from the file name only, but the index from
11641 CPAN can contain a hint to achieve a return value of true for other
11642 filenames too.
11643
11644 =item CPAN::Distribution::is_tested()
11645
11646 List all the distributions that have been tested sucessfully but not
11647 yet installed. See also C<install_tested>.
11648
11649 =item CPAN::Distribution::look()
11650
11651 Changes to the directory where the distribution has been unpacked and
11652 opens a subshell there. Exiting the subshell returns.
11653
11654 =item CPAN::Distribution::make()
11655
11656 First runs the C<get> method to make sure the distribution is
11657 downloaded and unpacked. Changes to the directory where the
11658 distribution has been unpacked and runs the external commands C<perl
11659 Makefile.PL> or C<perl Build.PL> and C<make> there.
11660
11661 =item CPAN::Distribution::perldoc()
11662
11663 Downloads the pod documentation of the file associated with a
11664 distribution (in html format) and runs it through the external
11665 command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
11666 isn't available, it converts it to plain text with external
11667 command html2text and runs it through the pager specified
11668 in C<$CPAN::Config->{pager}>
11669
11670 =item CPAN::Distribution::prefs()
11671
11672 Returns the hash reference from the first matching YAML file that the
11673 user has deposited in the C<prefs_dir/> directory. The first
11674 succeeding match wins. The files in the C<prefs_dir/> are processed
11675 alphabetically and the canonical distroname (e.g.
11676 AUTHOR/Foo-Bar-3.14.tar.gz) is matched against the regular expressions
11677 stored in the $root->{match}{distribution} attribute value.
11678 Additionally all module names contained in a distribution are matched
11679 agains the regular expressions in the $root->{match}{module} attribute
11680 value. The two match values are ANDed together. Each of the two
11681 attributes are optional.
11682
11683 =item CPAN::Distribution::prereq_pm()
11684
11685 Returns the hash reference that has been announced by a distribution
11686 as the the C<requires> and C<build_requires> elements. These can be
11687 declared either by the C<META.yml> (if authoritative) or can be
11688 deposited after the run of C<Build.PL> in the file C<./_build/prereqs>
11689 or after the run of C<Makfile.PL> written as the C<PREREQ_PM> hash in
11690 a comment in the produced C<Makefile>. I<Note>: this method only works
11691 after an attempt has been made to C<make> the distribution. Returns
11692 undef otherwise.
11693
11694 =item CPAN::Distribution::readme()
11695
11696 Downloads the README file associated with a distribution and runs it
11697 through the pager specified in C<$CPAN::Config->{pager}>.
11698
11699 =item CPAN::Distribution::reports()
11700
11701 Downloads report data for this distribution from cpantesters.perl.org
11702 and displays a subset of them.
11703
11704 =item CPAN::Distribution::read_yaml()
11705
11706 Returns the content of the META.yml of this distro as a hashref. Note:
11707 works only after an attempt has been made to C<make> the distribution.
11708 Returns undef otherwise. Also returns undef if the content of META.yml
11709 is not authoritative. (The rules about what exactly makes the content
11710 authoritative are still in flux.)
11711
11712 =item CPAN::Distribution::test()
11713
11714 Changes to the directory where the distribution has been unpacked and
11715 runs C<make test> there.
11716
11717 =item CPAN::Distribution::uptodate()
11718
11719 Returns 1 if all the modules contained in the distribution are
11720 uptodate. Relies on containsmods.
11721
11722 =item CPAN::Index::force_reload()
11723
11724 Forces a reload of all indices.
11725
11726 =item CPAN::Index::reload()
11727
11728 Reloads all indices if they have not been read for more than
11729 C<$CPAN::Config->{index_expire}> days.
11730
11731 =item CPAN::InfoObj::dump()
11732
11733 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
11734 inherit this method. It prints the data structure associated with an
11735 object. Useful for debugging. Note: the data structure is considered
11736 internal and thus subject to change without notice.
11737
11738 =item CPAN::Module::as_glimpse()
11739
11740 Returns a one-line description of the module in four columns: The
11741 first column contains the word C<Module>, the second column consists
11742 of one character: an equals sign if this module is already installed
11743 and uptodate, a less-than sign if this module is installed but can be
11744 upgraded, and a space if the module is not installed. The third column
11745 is the name of the module and the fourth column gives maintainer or
11746 distribution information.
11747
11748 =item CPAN::Module::as_string()
11749
11750 Returns a multi-line description of the module
11751
11752 =item CPAN::Module::clean()
11753
11754 Runs a clean on the distribution associated with this module.
11755
11756 =item CPAN::Module::cpan_file()
11757
11758 Returns the filename on CPAN that is associated with the module.
11759
11760 =item CPAN::Module::cpan_version()
11761
11762 Returns the latest version of this module available on CPAN.
11763
11764 =item CPAN::Module::cvs_import()
11765
11766 Runs a cvs_import on the distribution associated with this module.
11767
11768 =item CPAN::Module::description()
11769
11770 Returns a 44 character description of this module. Only available for
11771 modules listed in The Module List (CPAN/modules/00modlist.long.html
11772 or 00modlist.long.txt.gz)
11773
11774 =item CPAN::Module::distribution()
11775
11776 Returns the CPAN::Distribution object that contains the current
11777 version of this module.
11778
11779 =item CPAN::Module::dslip_status()
11780
11781 Returns a hash reference. The keys of the hash are the letters C<D>,
11782 C<S>, C<L>, C<I>, and <P>, for development status, support level,
11783 language, interface and public licence respectively. The data for the
11784 DSLIP status are collected by pause.perl.org when authors register
11785 their namespaces. The values of the 5 hash elements are one-character
11786 words whose meaning is described in the table below. There are also 5
11787 hash elements C<DV>, C<SV>, C<LV>, C<IV>, and <PV> that carry a more
11788 verbose value of the 5 status variables.
11789
11790 Where the 'DSLIP' characters have the following meanings:
11791
11792   D - Development Stage  (Note: *NO IMPLIED TIMESCALES*):
11793     i   - Idea, listed to gain consensus or as a placeholder
11794     c   - under construction but pre-alpha (not yet released)
11795     a/b - Alpha/Beta testing
11796     R   - Released
11797     M   - Mature (no rigorous definition)
11798     S   - Standard, supplied with Perl 5
11799
11800   S - Support Level:
11801     m   - Mailing-list
11802     d   - Developer
11803     u   - Usenet newsgroup comp.lang.perl.modules
11804     n   - None known, try comp.lang.perl.modules
11805     a   - abandoned; volunteers welcome to take over maintainance
11806
11807   L - Language Used:
11808     p   - Perl-only, no compiler needed, should be platform independent
11809     c   - C and perl, a C compiler will be needed
11810     h   - Hybrid, written in perl with optional C code, no compiler needed
11811     +   - C++ and perl, a C++ compiler will be needed
11812     o   - perl and another language other than C or C++
11813
11814   I - Interface Style
11815     f   - plain Functions, no references used
11816     h   - hybrid, object and function interfaces available
11817     n   - no interface at all (huh?)
11818     r   - some use of unblessed References or ties
11819     O   - Object oriented using blessed references and/or inheritance
11820
11821   P - Public License
11822     p   - Standard-Perl: user may choose between GPL and Artistic
11823     g   - GPL: GNU General Public License
11824     l   - LGPL: "GNU Lesser General Public License" (previously known as
11825           "GNU Library General Public License")
11826     b   - BSD: The BSD License
11827     a   - Artistic license alone
11828     2   - Artistic license 2.0 or later
11829     o   - open source: appoved by www.opensource.org
11830     d   - allows distribution without restrictions
11831     r   - restricted distribtion
11832     n   - no license at all
11833
11834 =item CPAN::Module::force($method,@args)
11835
11836 Forces CPAN to perform a task that it normally would have refused to
11837 do. Force takes as arguments a method name to be called and any number
11838 of additional arguments that should be passed to the called method.
11839 The internals of the object get the needed changes so that CPAN.pm
11840 does not refuse to take the action. See also the section above on the
11841 C<force> and the C<fforce> pragma.
11842
11843 =item CPAN::Module::get()
11844
11845 Runs a get on the distribution associated with this module.
11846
11847 =item CPAN::Module::inst_file()
11848
11849 Returns the filename of the module found in @INC. The first file found
11850 is reported just like perl itself stops searching @INC when it finds a
11851 module.
11852
11853 =item CPAN::Module::available_file()
11854
11855 Returns the filename of the module found in PERL5LIB or @INC. The
11856 first file found is reported. The advantage of this method over
11857 C<inst_file> is that modules that have been tested but not yet
11858 installed are included because PERL5LIB keeps track of tested modules.
11859
11860 =item CPAN::Module::inst_version()
11861
11862 Returns the version number of the installed module in readable format.
11863
11864 =item CPAN::Module::available_version()
11865
11866 Returns the version number of the available module in readable format.
11867
11868 =item CPAN::Module::install()
11869
11870 Runs an C<install> on the distribution associated with this module.
11871
11872 =item CPAN::Module::look()
11873
11874 Changes to the directory where the distribution associated with this
11875 module has been unpacked and opens a subshell there. Exiting the
11876 subshell returns.
11877
11878 =item CPAN::Module::make()
11879
11880 Runs a C<make> on the distribution associated with this module.
11881
11882 =item CPAN::Module::manpage_headline()
11883
11884 If module is installed, peeks into the module's manpage, reads the
11885 headline and returns it. Moreover, if the module has been downloaded
11886 within this session, does the equivalent on the downloaded module even
11887 if it is not installed.
11888
11889 =item CPAN::Module::perldoc()
11890
11891 Runs a C<perldoc> on this module.
11892
11893 =item CPAN::Module::readme()
11894
11895 Runs a C<readme> on the distribution associated with this module.
11896
11897 =item CPAN::Module::reports()
11898
11899 Calls the reports() method on the associated distribution object.
11900
11901 =item CPAN::Module::test()
11902
11903 Runs a C<test> on the distribution associated with this module.
11904
11905 =item CPAN::Module::uptodate()
11906
11907 Returns 1 if the module is installed and up-to-date.
11908
11909 =item CPAN::Module::userid()
11910
11911 Returns the author's ID of the module.
11912
11913 =back
11914
11915 =head2 Cache Manager
11916
11917 Currently the cache manager only keeps track of the build directory
11918 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
11919 deletes complete directories below C<build_dir> as soon as the size of
11920 all directories there gets bigger than $CPAN::Config->{build_cache}
11921 (in MB). The contents of this cache may be used for later
11922 re-installations that you intend to do manually, but will never be
11923 trusted by CPAN itself. This is due to the fact that the user might
11924 use these directories for building modules on different architectures.
11925
11926 There is another directory ($CPAN::Config->{keep_source_where}) where
11927 the original distribution files are kept. This directory is not
11928 covered by the cache manager and must be controlled by the user. If
11929 you choose to have the same directory as build_dir and as
11930 keep_source_where directory, then your sources will be deleted with
11931 the same fifo mechanism.
11932
11933 =head2 Bundles
11934
11935 A bundle is just a perl module in the namespace Bundle:: that does not
11936 define any functions or methods. It usually only contains documentation.
11937
11938 It starts like a perl module with a package declaration and a $VERSION
11939 variable. After that the pod section looks like any other pod with the
11940 only difference being that I<one special pod section> exists starting with
11941 (verbatim):
11942
11943     =head1 CONTENTS
11944
11945 In this pod section each line obeys the format
11946
11947         Module_Name [Version_String] [- optional text]
11948
11949 The only required part is the first field, the name of a module
11950 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
11951 of the line is optional. The comment part is delimited by a dash just
11952 as in the man page header.
11953
11954 The distribution of a bundle should follow the same convention as
11955 other distributions.
11956
11957 Bundles are treated specially in the CPAN package. If you say 'install
11958 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
11959 the modules in the CONTENTS section of the pod. You can install your
11960 own Bundles locally by placing a conformant Bundle file somewhere into
11961 your @INC path. The autobundle() command which is available in the
11962 shell interface does that for you by including all currently installed
11963 modules in a snapshot bundle file.
11964
11965 =head1 PREREQUISITES
11966
11967 If you have a local mirror of CPAN and can access all files with
11968 "file:" URLs, then you only need a perl better than perl5.003 to run
11969 this module. Otherwise Net::FTP is strongly recommended. LWP may be
11970 required for non-UNIX systems or if your nearest CPAN site is
11971 associated with a URL that is not C<ftp:>.
11972
11973 If you have neither Net::FTP nor LWP, there is a fallback mechanism
11974 implemented for an external ftp command or for an external lynx
11975 command.
11976
11977 =head1 UTILITIES
11978
11979 =head2 Finding packages and VERSION
11980
11981 This module presumes that all packages on CPAN
11982
11983 =over 2
11984
11985 =item *
11986
11987 declare their $VERSION variable in an easy to parse manner. This
11988 prerequisite can hardly be relaxed because it consumes far too much
11989 memory to load all packages into the running program just to determine
11990 the $VERSION variable. Currently all programs that are dealing with
11991 version use something like this
11992
11993     perl -MExtUtils::MakeMaker -le \
11994         'print MM->parse_version(shift)' filename
11995
11996 If you are author of a package and wonder if your $VERSION can be
11997 parsed, please try the above method.
11998
11999 =item *
12000
12001 come as compressed or gzipped tarfiles or as zip files and contain a
12002 C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
12003 without much enthusiasm).
12004
12005 =back
12006
12007 =head2 Debugging
12008
12009 The debugging of this module is a bit complex, because we have
12010 interferences of the software producing the indices on CPAN, of the
12011 mirroring process on CPAN, of packaging, of configuration, of
12012 synchronicity, and of bugs within CPAN.pm.
12013
12014 For debugging the code of CPAN.pm itself in interactive mode some more
12015 or less useful debugging aid can be turned on for most packages within
12016 CPAN.pm with one of
12017
12018 =over 2
12019
12020 =item o debug package...
12021
12022 sets debug mode for packages.
12023
12024 =item o debug -package...
12025
12026 unsets debug mode for packages.
12027
12028 =item o debug all
12029
12030 turns debugging on for all packages.
12031
12032 =item o debug number
12033
12034 =back
12035
12036 which sets the debugging packages directly. Note that C<o debug 0>
12037 turns debugging off.
12038
12039 What seems quite a successful strategy is the combination of C<reload
12040 cpan> and the debugging switches. Add a new debug statement while
12041 running in the shell and then issue a C<reload cpan> and see the new
12042 debugging messages immediately without losing the current context.
12043
12044 C<o debug> without an argument lists the valid package names and the
12045 current set of packages in debugging mode. C<o debug> has built-in
12046 completion support.
12047
12048 For debugging of CPAN data there is the C<dump> command which takes
12049 the same arguments as make/test/install and outputs each object's
12050 Data::Dumper dump. If an argument looks like a perl variable and
12051 contains one of C<$>, C<@> or C<%>, it is eval()ed and fed to
12052 Data::Dumper directly.
12053
12054 =head2 Floppy, Zip, Offline Mode
12055
12056 CPAN.pm works nicely without network too. If you maintain machines
12057 that are not networked at all, you should consider working with file:
12058 URLs. Of course, you have to collect your modules somewhere first. So
12059 you might use CPAN.pm to put together all you need on a networked
12060 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
12061 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
12062 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
12063 with this floppy. See also below the paragraph about CD-ROM support.
12064
12065 =head2 Basic Utilities for Programmers
12066
12067 =over 2
12068
12069 =item has_inst($module)
12070
12071 Returns true if the module is installed. Used to load all modules into
12072 the running CPAN.pm which are considered optional. The config variable
12073 C<dontload_list> can be used to intercept the C<has_inst()> call such
12074 that an optional module is not loaded despite being available. For
12075 example the following command will prevent that C<YAML.pm> is being
12076 loaded:
12077
12078     cpan> o conf dontload_list push YAML
12079
12080 See the source for details.
12081
12082 =item has_usable($module)
12083
12084 Returns true if the module is installed and is in a usable state. Only
12085 useful for a handful of modules that are used internally. See the
12086 source for details.
12087
12088 =item instance($module)
12089
12090 The constructor for all the singletons used to represent modules,
12091 distributions, authors and bundles. If the object already exists, this
12092 method returns the object, otherwise it calls the constructor.
12093
12094 =back
12095
12096 =head1 SECURITY
12097
12098 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
12099 install foreign, unmasked, unsigned code on your machine. We compare
12100 to a checksum that comes from the net just as the distribution file
12101 itself. But we try to make it easy to add security on demand:
12102
12103 =head2 Cryptographically signed modules
12104
12105 Since release 1.77 CPAN.pm has been able to verify cryptographically
12106 signed module distributions using Module::Signature.  The CPAN modules
12107 can be signed by their authors, thus giving more security.  The simple
12108 unsigned MD5 checksums that were used before by CPAN protect mainly
12109 against accidental file corruption.
12110
12111 You will need to have Module::Signature installed, which in turn
12112 requires that you have at least one of Crypt::OpenPGP module or the
12113 command-line F<gpg> tool installed.
12114
12115 You will also need to be able to connect over the Internet to the public
12116 keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
12117
12118 The configuration parameter check_sigs is there to turn signature
12119 checking on or off.
12120
12121 =head1 EXPORT
12122
12123 Most functions in package CPAN are exported per default. The reason
12124 for this is that the primary use is intended for the cpan shell or for
12125 one-liners.
12126
12127 =head1 ENVIRONMENT
12128
12129 When the CPAN shell enters a subshell via the look command, it sets
12130 the environment CPAN_SHELL_LEVEL to 1 or increments it if it is
12131 already set.
12132
12133 When CPAN runs, it sets the environment variable PERL5_CPAN_IS_RUNNING
12134 to the ID of the running process. It also sets
12135 PERL5_CPANPLUS_IS_RUNNING to prevent runaway processes which could
12136 happen with older versions of Module::Install.
12137
12138 When running C<perl Makefile.PL>, the environment variable
12139 C<PERL5_CPAN_IS_EXECUTING> is set to the full path of the
12140 C<Makefile.PL> that is being executed. This prevents runaway processes
12141 with newer versions of Module::Install.
12142
12143 When the config variable ftp_passive is set, all downloads will be run
12144 with the environment variable FTP_PASSIVE set to this value. This is
12145 in general a good idea as it influences both Net::FTP and LWP based
12146 connections. The same effect can be achieved by starting the cpan
12147 shell with this environment variable set. For Net::FTP alone, one can
12148 also always set passive mode by running libnetcfg.
12149
12150 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
12151
12152 Populating a freshly installed perl with my favorite modules is pretty
12153 easy if you maintain a private bundle definition file. To get a useful
12154 blueprint of a bundle definition file, the command autobundle can be used
12155 on the CPAN shell command line. This command writes a bundle definition
12156 file for all modules that are installed for the currently running perl
12157 interpreter. It's recommended to run this command only once and from then
12158 on maintain the file manually under a private name, say
12159 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
12160
12161     cpan> install Bundle::my_bundle
12162
12163 then answer a few questions and then go out for a coffee.
12164
12165 Maintaining a bundle definition file means keeping track of two
12166 things: dependencies and interactivity. CPAN.pm sometimes fails on
12167 calculating dependencies because not all modules define all MakeMaker
12168 attributes correctly, so a bundle definition file should specify
12169 prerequisites as early as possible. On the other hand, it's a bit
12170 annoying that many distributions need some interactive configuring. So
12171 what I try to accomplish in my private bundle file is to have the
12172 packages that need to be configured early in the file and the gentle
12173 ones later, so I can go out after a few minutes and leave CPAN.pm
12174 untended.
12175
12176 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
12177
12178 Thanks to Graham Barr for contributing the following paragraphs about
12179 the interaction between perl, and various firewall configurations. For
12180 further information on firewalls, it is recommended to consult the
12181 documentation that comes with the ncftp program. If you are unable to
12182 go through the firewall with a simple Perl setup, it is very likely
12183 that you can configure ncftp so that it works for your firewall.
12184
12185 =head2 Three basic types of firewalls
12186
12187 Firewalls can be categorized into three basic types.
12188
12189 =over 4
12190
12191 =item http firewall
12192
12193 This is where the firewall machine runs a web server and to access the
12194 outside world you must do it via the web server. If you set environment
12195 variables like http_proxy or ftp_proxy to a values beginning with http://
12196 or in your web browser you have to set proxy information then you know
12197 you are running an http firewall.
12198
12199 To access servers outside these types of firewalls with perl (even for
12200 ftp) you will need to use LWP.
12201
12202 =item ftp firewall
12203
12204 This where the firewall machine runs an ftp server. This kind of
12205 firewall will only let you access ftp servers outside the firewall.
12206 This is usually done by connecting to the firewall with ftp, then
12207 entering a username like "user@outside.host.com"
12208
12209 To access servers outside these type of firewalls with perl you
12210 will need to use Net::FTP.
12211
12212 =item One way visibility
12213
12214 I say one way visibility as these firewalls try to make themselves look
12215 invisible to the users inside the firewall. An FTP data connection is
12216 normally created by sending the remote server your IP address and then
12217 listening for the connection. But the remote server will not be able to
12218 connect to you because of the firewall. So for these types of firewall
12219 FTP connections need to be done in a passive mode.
12220
12221 There are two that I can think off.
12222
12223 =over 4
12224
12225 =item SOCKS
12226
12227 If you are using a SOCKS firewall you will need to compile perl and link
12228 it with the SOCKS library, this is what is normally called a 'socksified'
12229 perl. With this executable you will be able to connect to servers outside
12230 the firewall as if it is not there.
12231
12232 =item IP Masquerade
12233
12234 This is the firewall implemented in the Linux kernel, it allows you to
12235 hide a complete network behind one IP address. With this firewall no
12236 special compiling is needed as you can access hosts directly.
12237
12238 For accessing ftp servers behind such firewalls you usually need to
12239 set the environment variable C<FTP_PASSIVE> or the config variable
12240 ftp_passive to a true value.
12241
12242 =back
12243
12244 =back
12245
12246 =head2 Configuring lynx or ncftp for going through a firewall
12247
12248 If you can go through your firewall with e.g. lynx, presumably with a
12249 command such as
12250
12251     /usr/local/bin/lynx -pscott:tiger
12252
12253 then you would configure CPAN.pm with the command
12254
12255     o conf lynx "/usr/local/bin/lynx -pscott:tiger"
12256
12257 That's all. Similarly for ncftp or ftp, you would configure something
12258 like
12259
12260     o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
12261
12262 Your mileage may vary...
12263
12264 =head1 FAQ
12265
12266 =over 4
12267
12268 =item 1)
12269
12270 I installed a new version of module X but CPAN keeps saying,
12271 I have the old version installed
12272
12273 Most probably you B<do> have the old version installed. This can
12274 happen if a module installs itself into a different directory in the
12275 @INC path than it was previously installed. This is not really a
12276 CPAN.pm problem, you would have the same problem when installing the
12277 module manually. The easiest way to prevent this behaviour is to add
12278 the argument C<UNINST=1> to the C<make install> call, and that is why
12279 many people add this argument permanently by configuring
12280
12281   o conf make_install_arg UNINST=1
12282
12283 =item 2)
12284
12285 So why is UNINST=1 not the default?
12286
12287 Because there are people who have their precise expectations about who
12288 may install where in the @INC path and who uses which @INC array. In
12289 fine tuned environments C<UNINST=1> can cause damage.
12290
12291 =item 3)
12292
12293 I want to clean up my mess, and install a new perl along with
12294 all modules I have. How do I go about it?
12295
12296 Run the autobundle command for your old perl and optionally rename the
12297 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
12298 with the Configure option prefix, e.g.
12299
12300     ./Configure -Dprefix=/usr/local/perl-5.6.78.9
12301
12302 Install the bundle file you produced in the first step with something like
12303
12304     cpan> install Bundle::mybundle
12305
12306 and you're done.
12307
12308 =item 4)
12309
12310 When I install bundles or multiple modules with one command
12311 there is too much output to keep track of.
12312
12313 You may want to configure something like
12314
12315   o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
12316   o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
12317
12318 so that STDOUT is captured in a file for later inspection.
12319
12320
12321 =item 5)
12322
12323 I am not root, how can I install a module in a personal directory?
12324
12325 First of all, you will want to use your own configuration, not the one
12326 that your root user installed. If you do not have permission to write
12327 in the cpan directory that root has configured, you will be asked if
12328 you want to create your own config. Answering "yes" will bring you into
12329 CPAN's configuration stage, using the system config for all defaults except
12330 things that have to do with CPAN's work directory, saving your choices to
12331 your MyConfig.pm file.
12332
12333 You can also manually initiate this process with the following command:
12334
12335     % perl -MCPAN -e 'mkmyconfig'
12336
12337 or by running
12338
12339     mkmyconfig
12340
12341 from the CPAN shell.
12342
12343 You will most probably also want to configure something like this:
12344
12345   o conf makepl_arg "LIB=~/myperl/lib \
12346                     INSTALLMAN1DIR=~/myperl/man/man1 \
12347                     INSTALLMAN3DIR=~/myperl/man/man3 \
12348                     INSTALLSCRIPT=~/myperl/bin \
12349                     INSTALLBIN=~/myperl/bin"
12350
12351 and then (oh joy) the equivalent command for Module::Build. That would
12352 be
12353
12354   o conf mbuildpl_arg "--lib=~/myperl/lib \
12355                     --installman1dir=~/myperl/man/man1 \
12356                     --installman3dir=~/myperl/man/man3 \
12357                     --installscript=~/myperl/bin \
12358                     --installbin=~/myperl/bin"
12359
12360 You can make this setting permanent like all C<o conf> settings with
12361 C<o conf commit> or by setting C<auto_commit> beforehand.
12362
12363 You will have to add ~/myperl/man to the MANPATH environment variable
12364 and also tell your perl programs to look into ~/myperl/lib, e.g. by
12365 including
12366
12367   use lib "$ENV{HOME}/myperl/lib";
12368
12369 or setting the PERL5LIB environment variable.
12370
12371 While we're speaking about $ENV{HOME}, it might be worth mentioning,
12372 that for Windows we use the File::HomeDir module that provides an
12373 equivalent to the concept of the home directory on Unix.
12374
12375 Another thing you should bear in mind is that the UNINST parameter can
12376 be dangerous when you are installing into a private area because you
12377 might accidentally remove modules that other people depend on that are
12378 not using the private area.
12379
12380 =item 6)
12381
12382 How to get a package, unwrap it, and make a change before building it?
12383
12384 Have a look at the C<look> (!) command.
12385
12386 =item 7)
12387
12388 I installed a Bundle and had a couple of fails. When I
12389 retried, everything resolved nicely. Can this be fixed to work
12390 on first try?
12391
12392 The reason for this is that CPAN does not know the dependencies of all
12393 modules when it starts out. To decide about the additional items to
12394 install, it just uses data found in the META.yml file or the generated
12395 Makefile. An undetected missing piece breaks the process. But it may
12396 well be that your Bundle installs some prerequisite later than some
12397 depending item and thus your second try is able to resolve everything.
12398 Please note, CPAN.pm does not know the dependency tree in advance and
12399 cannot sort the queue of things to install in a topologically correct
12400 order. It resolves perfectly well IF all modules declare the
12401 prerequisites correctly with the PREREQ_PM attribute to MakeMaker or
12402 the C<requires> stanza of Module::Build. For bundles which fail and
12403 you need to install often, it is recommended to sort the Bundle
12404 definition file manually.
12405
12406 =item 8)
12407
12408 In our intranet we have many modules for internal use. How
12409 can I integrate these modules with CPAN.pm but without uploading
12410 the modules to CPAN?
12411
12412 Have a look at the CPAN::Site module.
12413
12414 =item 9)
12415
12416 When I run CPAN's shell, I get an error message about things in my
12417 /etc/inputrc (or ~/.inputrc) file.
12418
12419 These are readline issues and can only be fixed by studying readline
12420 configuration on your architecture and adjusting the referenced file
12421 accordingly. Please make a backup of the /etc/inputrc or ~/.inputrc
12422 and edit them. Quite often harmless changes like uppercasing or
12423 lowercasing some arguments solves the problem.
12424
12425 =item 10)
12426
12427 Some authors have strange characters in their names.
12428
12429 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
12430 expecting ISO-8859-1 charset, a converter can be activated by setting
12431 term_is_latin to a true value in your config file. One way of doing so
12432 would be
12433
12434     cpan> o conf term_is_latin 1
12435
12436 If other charset support is needed, please file a bugreport against
12437 CPAN.pm at rt.cpan.org and describe your needs. Maybe we can extend
12438 the support or maybe UTF-8 terminals become widely available.
12439
12440 Note: this config variable is deprecated and will be removed in a
12441 future version of CPAN.pm. It will be replaced with the conventions
12442 around the family of $LANG and $LC_* environment variables.
12443
12444 =item 11)
12445
12446 When an install fails for some reason and then I correct the error
12447 condition and retry, CPAN.pm refuses to install the module, saying
12448 C<Already tried without success>.
12449
12450 Use the force pragma like so
12451
12452   force install Foo::Bar
12453
12454 Or you can use
12455
12456   look Foo::Bar
12457
12458 and then 'make install' directly in the subshell.
12459
12460 =item 12)
12461
12462 How do I install a "DEVELOPER RELEASE" of a module?
12463
12464 By default, CPAN will install the latest non-developer release of a
12465 module. If you want to install a dev release, you have to specify the
12466 partial path starting with the author id to the tarball you wish to
12467 install, like so:
12468
12469     cpan> install KWILLIAMS/Module-Build-0.27_07.tar.gz
12470
12471 Note that you can use the C<ls> command to get this path listed.
12472
12473 =item 13)
12474
12475 How do I install a module and all its dependencies from the commandline,
12476 without being prompted for anything, despite my CPAN configuration
12477 (or lack thereof)?
12478
12479 CPAN uses ExtUtils::MakeMaker's prompt() function to ask its questions, so
12480 if you set the PERL_MM_USE_DEFAULT environment variable, you shouldn't be
12481 asked any questions at all (assuming the modules you are installing are
12482 nice about obeying that variable as well):
12483
12484     % PERL_MM_USE_DEFAULT=1 perl -MCPAN -e 'install My::Module'
12485
12486 =item 14)
12487
12488 How do I create a Module::Build based Build.PL derived from an
12489 ExtUtils::MakeMaker focused Makefile.PL?
12490
12491 http://search.cpan.org/search?query=Module::Build::Convert
12492
12493 http://www.refcnt.org/papers/module-build-convert
12494
12495 =item 15)
12496
12497 What's the best CPAN site for me?
12498
12499 The urllist config parameter is yours. You can add and remove sites at
12500 will. You should find out which sites have the best uptodateness,
12501 bandwidth, reliability, etc. and are topologically close to you. Some
12502 people prefer fast downloads, others uptodateness, others reliability.
12503 You decide which to try in which order.
12504
12505 Henk P. Penning maintains a site that collects data about CPAN sites:
12506
12507   http://www.cs.uu.nl/people/henkp/mirmon/cpan.html
12508
12509 =item 16)
12510
12511 Why do I get asked the same questions every time I start the shell?
12512
12513 You can make your configuration changes permanent by calling the
12514 command C<o conf commit>. Alternatively set the C<auto_commit>
12515 variable to true by running C<o conf init auto_commit> and answering
12516 the following question with yes.
12517
12518 =back
12519
12520 =head1 COMPATIBILITY
12521
12522 =head2 OLD PERL VERSIONS
12523
12524 CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted
12525 newer versions. It is getting more and more difficult to get the
12526 minimal prerequisites working on older perls. It is close to
12527 impossible to get the whole Bundle::CPAN working there. If you're in
12528 the position to have only these old versions, be advised that CPAN is
12529 designed to work fine without the Bundle::CPAN installed.
12530
12531 To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is
12532 compatible with ancient perls and that File::Temp is listed as a
12533 prerequisite but CPAN has reasonable workarounds if it is missing.
12534
12535 =head2 CPANPLUS
12536
12537 This module and its competitor, the CPANPLUS module, are both much
12538 cooler than the other. CPAN.pm is older. CPANPLUS was designed to be
12539 more modular but it was never tried to make it compatible with CPAN.pm.
12540
12541 =head1 SECURITY ADVICE
12542
12543 This software enables you to upgrade software on your computer and so
12544 is inherently dangerous because the newly installed software may
12545 contain bugs and may alter the way your computer works or even make it
12546 unusable. Please consider backing up your data before every upgrade.
12547
12548 =head1 BUGS
12549
12550 Please report bugs via L<http://rt.cpan.org/>
12551
12552 Before submitting a bug, please make sure that the traditional method
12553 of building a Perl module package from a shell by following the
12554 installation instructions of that package still works in your
12555 environment.
12556
12557 =head1 AUTHOR
12558
12559 Andreas Koenig C<< <andk@cpan.org> >>
12560
12561 =head1 LICENSE
12562
12563 This program is free software; you can redistribute it and/or
12564 modify it under the same terms as Perl itself.
12565
12566 See L<http://www.perl.com/perl/misc/Artistic.html>
12567
12568 =head1 TRANSLATIONS
12569
12570 Kawai,Takanori provides a Japanese translation of this manpage at
12571 L<http://homepage3.nifty.com/hippo2000/perltips/CPAN.htm>
12572
12573 =head1 SEE ALSO
12574
12575 L<cpan>, L<CPAN::Nox>, L<CPAN::Version>
12576
12577 =cut
12578
12579