lib/CPAN.pm

   1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
   2 use strict;
   3 package CPAN;
   4 $CPAN::VERSION = '1.9205';
   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 #-> CPAN::soft_chdir_with_alternatives ;
 363 sub soft_chdir_with_alternatives ($) {
 364     my($cwd) = @_;
 365     unless (@$cwd) {
 366         my $root = File::Spec->rootdir();
 367         $CPAN::Frontend->mywarn(qq{Warning: no good directory to chdir to!
 368 Trying '$root' as temporary haven.
 369 });
 370         push @$cwd, $root;
 371     }
 372     while () {
 373         if (chdir $cwd->[0]) {
 374             return;
 375         } else {
 376             if (@$cwd>1) {
 377                 $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $!
 378 Trying to chdir to "$cwd->[1]" instead.
 379 });
 380                 shift @$cwd;
 381             } else {
 382                 $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!});
 383             }
 384         }
 385     }
 386 }
 387
 388 sub _flock {
 389     my($fh,$mode) = @_;
 390     if ($Config::Config{d_flock}) {
 391         return flock $fh, $mode;
 392     } elsif (!$Have_warned->{"d_flock"}++) {
 393         $CPAN::Frontend->mywarn("Your OS does not support locking; continuing and ignoring all locking issues\n");
 394         $CPAN::Frontend->mysleep(5);
 395         return 1;
 396     } else {
 397         return 1;
 398     }
 399 }
 400
 401 sub _yaml_module () {
 402     my $yaml_module = $CPAN::Config->{yaml_module} || "YAML";
 403     if (
 404         $yaml_module ne "YAML"
 405         &&
 406         !$CPAN::META->has_inst($yaml_module)
 407        ) {
 408         # $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back to 'YAML'\n");
 409         $yaml_module = "YAML";
 410     }
 411     if ($yaml_module eq "YAML"
 412         &&
 413         $CPAN::META->has_inst($yaml_module)
 414         &&
 415         $YAML::VERSION < 0.60
 416         &&
 417         !$Have_warned->{"YAML"}++
 418        ) {
 419         $CPAN::Frontend->mywarn("Warning: YAML version '$YAML::VERSION' is too low, please upgrade!\n".
 420                                 "I'll continue but problems are *very* likely to happen.\n"
 421                                );
 422         $CPAN::Frontend->mysleep(5);
 423     }
 424     return $yaml_module;
 425 }
 426
 427 # CPAN::_yaml_loadfile
 428 sub _yaml_loadfile {
 429     my($self,$local_file) = @_;
 430     return +[] unless -s $local_file;
 431     my $yaml_module = _yaml_module;
 432     if ($CPAN::META->has_inst($yaml_module)) {
 433         # temporarly enable yaml code deserialisation
 434         no strict 'refs';
 435         # 5.6.2 could not do the local() with the reference
 436         local $YAML::LoadCode;
 437         local $YAML::Syck::LoadCode;
 438         ${ "$yaml_module\::LoadCode" } = $CPAN::Config->{yaml_load_code} || 0;
 439
 440         my $code;
 441         if ($code = UNIVERSAL::can($yaml_module, "LoadFile")) {
 442             my @yaml;
 443             eval { @yaml = $code->($local_file); };
 444             if ($@) {
 445                 # this shall not be done by the frontend
 446                 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
 447             }
 448             return \@yaml;
 449         } elsif ($code = UNIVERSAL::can($yaml_module, "Load")) {
 450             local *FH;
 451             open FH, $local_file or die "Could not open '$local_file': $!";
 452             local $/;
 453             my $ystream = <FH>;
 454             my @yaml;
 455             eval { @yaml = $code->($ystream); };
 456             if ($@) {
 457                 # this shall not be done by the frontend
 458                 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
 459             }
 460             return \@yaml;
 461         }
 462     } else {
 463         # this shall not be done by the frontend
 464         die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "parse");
 465     }
 466     return +[];
 467 }
 468
 469 # CPAN::_yaml_dumpfile
 470 sub _yaml_dumpfile {
 471     my($self,$local_file,@what) = @_;
 472     my $yaml_module = _yaml_module;
 473     if ($CPAN::META->has_inst($yaml_module)) {
 474         my $code;
 475         if (UNIVERSAL::isa($local_file, "FileHandle")) {
 476             $code = UNIVERSAL::can($yaml_module, "Dump");
 477             eval { print $local_file $code->(@what) };
 478         } elsif ($code = UNIVERSAL::can($yaml_module, "DumpFile")) {
 479             eval { $code->($local_file,@what); };
 480         } elsif ($code = UNIVERSAL::can($yaml_module, "Dump")) {
 481             local *FH;
 482             open FH, ">$local_file" or die "Could not open '$local_file': $!";
 483             print FH $code->(@what);
 484         }
 485         if ($@) {
 486             die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"dump",$@);
 487         }
 488     } else {
 489         if (UNIVERSAL::isa($local_file, "FileHandle")) {
 490             # I think this case does not justify a warning at all
 491         } else {
 492             die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "dump");
 493         }
 494     }
 495 }
 496
 497 sub _init_sqlite () {
 498     unless ($CPAN::META->has_inst("CPAN::SQLite")) {
 499         $CPAN::Frontend->mywarn(qq{CPAN::SQLite not installed, trying to work without\n})
 500             unless $Have_warned->{"CPAN::SQLite"}++;
 501         return;
 502     }
 503     require CPAN::SQLite::META; # not needed since CVS version of 2006-12-17
 504     $CPAN::SQLite ||= CPAN::SQLite::META->new($CPAN::META);
 505 }
 506
 507 {
 508     my $negative_cache = {};
 509     sub _sqlite_running {
 510         if ($negative_cache->{time} && time < $negative_cache->{time} + 60) {
 511             # need to cache the result, otherwise too slow
 512             return $negative_cache->{fact};
 513         } else {
 514             $negative_cache = {}; # reset
 515         }
 516         my $ret = $CPAN::Config->{use_sqlite} && ($CPAN::SQLite || _init_sqlite());
 517         return $ret if $ret; # fast anyway
 518         $negative_cache->{time} = time;
 519         return $negative_cache->{fact} = $ret;
 520     }
 521 }
 522
 523 package CPAN::CacheMgr;
 524 use strict;
 525 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
 526 use File::Find;
 527
 528 package CPAN::FTP;
 529 use strict;
 530 use Fcntl qw(:flock);
 531 use vars qw($connect_to_internet_ok $Ua $Thesite $ThesiteURL $Themethod);
 532 @CPAN::FTP::ISA = qw(CPAN::Debug);
 533
 534 package CPAN::LWP::UserAgent;
 535 use strict;
 536 use vars qw(@ISA $USER $PASSWD $SETUPDONE);
 537 # we delay requiring LWP::UserAgent and setting up inheritance until we need it
 538
 539 package CPAN::Complete;
 540 use strict;
 541 @CPAN::Complete::ISA = qw(CPAN::Debug);
 542 # Q: where is the "How do I add a new command" HOWTO?
 543 # A: svn diff -r 1048:1049 where andk added the report command
 544 @CPAN::Complete::COMMANDS = sort qw(
 545                                     ? ! a b d h i m o q r u
 546                                     autobundle
 547                                     bye
 548                                     clean
 549                                     cvs_import
 550                                     dump
 551                                     exit
 552                                     failed
 553                                     force
 554                                     fforce
 555                                     hosts
 556                                     install
 557                                     install_tested
 558                                     is_tested
 559                                     look
 560                                     ls
 561                                     make
 562                                     mkmyconfig
 563                                     notest
 564                                     perldoc
 565                                     quit
 566                                     readme
 567                                     recent
 568                                     recompile
 569                                     reload
 570                                     report
 571                                     reports
 572                                     scripts
 573                                     smoke
 574                                     test
 575                                     upgrade
 576 );
 577
 578 package CPAN::Index;
 579 use strict;
 580 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED);
 581 @CPAN::Index::ISA = qw(CPAN::Debug);
 582 $LAST_TIME ||= 0;
 583 $DATE_OF_03 ||= 0;
 584 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
 585 sub PROTOCOL { 2.0 }
 586
 587 package CPAN::InfoObj;
 588 use strict;
 589 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
 590
 591 package CPAN::Author;
 592 use strict;
 593 @CPAN::Author::ISA = qw(CPAN::InfoObj);
 594
 595 package CPAN::Distribution;
 596 use strict;
 597 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
 598
 599 package CPAN::Bundle;
 600 use strict;
 601 @CPAN::Bundle::ISA = qw(CPAN::Module);
 602
 603 package CPAN::Module;
 604 use strict;
 605 @CPAN::Module::ISA = qw(CPAN::InfoObj);
 606
 607 package CPAN::Exception::RecursiveDependency;
 608 use strict;
 609 use overload '""' => "as_string";
 610
 611 # a module sees its distribution (no version)
 612 # a distribution sees its prereqs (which are module names) (usually with versions)
 613 # a bundle sees its module names and/or its distributions (no version)
 614
 615 sub new {
 616     my($class) = shift;
 617     my($deps) = shift;
 618     my (@deps,%seen,$loop_starts_with);
 619   DCHAIN: for my $dep (@$deps) {
 620         push @deps, {name => $dep, display_as => $dep};
 621         if ($seen{$dep}++) {
 622             $loop_starts_with = $dep;
 623             last DCHAIN;
 624         }
 625     }
 626     my $in_loop = 0;
 627     for my $i (0..$#deps) {
 628         my $x = $deps[$i]{name};
 629         $in_loop ||= $x eq $loop_starts_with;
 630         my $xo = CPAN::Shell->expandany($x) or next;
 631         if ($xo->isa("CPAN::Module")) {
 632             my $have = $xo->inst_version || "N/A";
 633             my($want,$d,$want_type);
 634             if ($i>0 and $d = $deps[$i-1]{name}) {
 635                 my $do = CPAN::Shell->expandany($d);
 636                 $want = $do->{prereq_pm}{requires}{$x};
 637                 if (defined $want) {
 638                     $want_type = "requires: ";
 639                 } else {
 640                     $want = $do->{prereq_pm}{build_requires}{$x};
 641                     if (defined $want) {
 642                         $want_type = "build_requires: ";
 643                     } else {
 644                         $want_type = "unknown status";
 645                         $want = "???";
 646                     }
 647                 }
 648             } else {
 649                 $want = $xo->cpan_version;
 650                 $want_type = "want: ";
 651             }
 652             $deps[$i]{have} = $have;
 653             $deps[$i]{want_type} = $want_type;
 654             $deps[$i]{want} = $want;
 655             $deps[$i]{display_as} = "$x (have: $have; $want_type$want)";
 656         } elsif ($xo->isa("CPAN::Distribution")) {
 657             $deps[$i]{display_as} = $xo->pretty_id;
 658             if ($in_loop) {
 659                 $xo->{make} = CPAN::Distrostatus->new("NO cannot resolve circular dependency");
 660             } else {
 661                 $xo->{make} = CPAN::Distrostatus->new("NO one dependency ($loop_starts_with) is a circular dependency");
 662             }
 663             $xo->store_persistent_state; # otherwise I will not reach
 664                                          # all involved parties for
 665                                          # the next session
 666         }
 667     }
 668     bless { deps => \@deps }, $class;
 669 }
 670
 671 sub as_string {
 672     my($self) = shift;
 673     my $ret = "\nRecursive dependency detected:\n    ";
 674     $ret .= join("\n => ", map {$_->{display_as}} @{$self->{deps}});
 675     $ret .= ".\nCannot resolve.\n";
 676     $ret;
 677 }
 678
 679 package CPAN::Exception::yaml_not_installed;
 680 use strict;
 681 use overload '""' => "as_string";
 682
 683 sub new {
 684     my($class,$module,$file,$during) = @_;
 685     bless { module => $module, file => $file, during => $during }, $class;
 686 }
 687
 688 sub as_string {
 689     my($self) = shift;
 690     "'$self->{module}' not installed, cannot $self->{during} '$self->{file}'\n";
 691 }
 692
 693 package CPAN::Exception::yaml_process_error;
 694 use strict;
 695 use overload '""' => "as_string";
 696
 697 sub new {
 698     my($class,$module,$file,$during,$error) = @_;
 699     bless { module => $module,
 700             file => $file,
 701             during => $during,
 702             error => $error }, $class;
 703 }
 704
 705 sub as_string {
 706     my($self) = shift;
 707     if ($self->{during}) {
 708         if ($self->{file}) {
 709             if ($self->{module}) {
 710                 if ($self->{error}) {
 711                     return "Alert: While trying to '$self->{during}' YAML file\n".
 712                         " '$self->{file}'\n".
 713                             "with '$self->{module}' the following error was encountered:\n".
 714                                 "  $self->{error}\n";
 715                 } else {
 716                     return "Alert: While trying to '$self->{during}' YAML file\n".
 717                         " '$self->{file}'\n".
 718                             "with '$self->{module}' some unknown error was encountered\n";
 719                 }
 720             } else {
 721                 return "Alert: While trying to '$self->{during}' YAML file\n".
 722                     " '$self->{file}'\n".
 723                         "some unknown error was encountered\n";
 724             }
 725         } else {
 726             return "Alert: While trying to '$self->{during}' some YAML file\n".
 727                     "some unknown error was encountered\n";
 728         }
 729     } else {
 730         return "Alert: unknown error encountered\n";
 731     }
 732 }
 733
 734 package CPAN::Prompt; use overload '""' => "as_string";
 735 use vars qw($prompt);
 736 $prompt = "cpan> ";
 737 $CPAN::CurrentCommandId ||= 0;
 738 sub new {
 739     bless {}, shift;
 740 }
 741 sub as_string {
 742     my $word = "cpan";
 743     unless ($CPAN::META->{LOCK}) {
 744         $word = "nolock_cpan";
 745     }
 746     if ($CPAN::Config->{commandnumber_in_prompt}) {
 747         sprintf "$word\[%d]> ", $CPAN::CurrentCommandId;
 748     } else {
 749         "$word> ";
 750     }
 751 }
 752
 753 package CPAN::URL; use overload '""' => "as_string", fallback => 1;
 754 # accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist),
 755 # planned are things like age or quality
 756 sub new {
 757     my($class,%args) = @_;
 758     bless {
 759            %args
 760           }, $class;
 761 }
 762 sub as_string {
 763     my($self) = @_;
 764     $self->text;
 765 }
 766 sub text {
 767     my($self,$set) = @_;
 768     if (defined $set) {
 769         $self->{TEXT} = $set;
 770     }
 771     $self->{TEXT};
 772 }
 773
 774 package CPAN::Distrostatus;
 775 use overload '""' => "as_string",
 776     fallback => 1;
 777 sub new {
 778     my($class,$arg) = @_;
 779     bless {
 780            TEXT => $arg,
 781            FAILED => substr($arg,0,2) eq "NO",
 782            COMMANDID => $CPAN::CurrentCommandId,
 783            TIME => time,
 784           }, $class;
 785 }
 786 sub commandid { shift->{COMMANDID} }
 787 sub failed { shift->{FAILED} }
 788 sub text {
 789     my($self,$set) = @_;
 790     if (defined $set) {
 791         $self->{TEXT} = $set;
 792     }
 793     $self->{TEXT};
 794 }
 795 sub as_string {
 796     my($self) = @_;
 797     $self->text;
 798 }
 799
 800 package CPAN::Shell;
 801 use strict;
 802 use vars qw(
 803             $ADVANCED_QUERY
 804             $AUTOLOAD
 805             $COLOR_REGISTERED
 806             $Help
 807             $autoload_recursion
 808             $reload
 809             @ISA
 810            );
 811 @CPAN::Shell::ISA = qw(CPAN::Debug);
 812 $COLOR_REGISTERED ||= 0;
 813 $Help = {
 814          '?' => \"help",
 815          '!' => "eval the rest of the line as perl",
 816          a => "whois author",
 817          autobundle => "wtite inventory into a bundle file",
 818          b => "info about bundle",
 819          bye => \"quit",
 820          clean => "clean up a distribution's build directory",
 821          # cvs_import
 822          d => "info about a distribution",
 823          # dump
 824          exit => \"quit",
 825          failed => "list all failed actions within current session",
 826          fforce => "redo a command from scratch",
 827          force => "redo a command",
 828          h => \"help",
 829          help => "overview over commands; 'help ...' explains specific commands",
 830          hosts => "statistics about recently used hosts",
 831          i => "info about authors/bundles/distributions/modules",
 832          install => "install a distribution",
 833          install_tested => "install all distributions tested OK",
 834          is_tested => "list all distributions tested OK",
 835          look => "open a subshell in a distribution's directory",
 836          ls => "list distributions according to a glob",
 837          m => "info about a module",
 838          make => "make/build a distribution",
 839          mkmyconfig => "write current config into a CPAN/MyConfig.pm file",
 840          notest => "run a (usually install) command but leave out the test phase",
 841          o => "'o conf ...' for config stuff; 'o debug ...' for debugging",
 842          perldoc => "try to get a manpage for a module",
 843          q => \"quit",
 844          quit => "leave the cpan shell",
 845          r => "review over upgradeable modules",
 846          readme => "display the README of a distro woth a pager",
 847          recent => "show recent uploads to the CPAN",
 848          # recompile
 849          reload => "'reload cpan' or 'reload index'",
 850          report => "test a distribution and send a test report to cpantesters",
 851          reports => "info about reported tests from cpantesters",
 852          # scripts
 853          # smoke
 854          test => "test a distribution",
 855          u => "display uninstalled modules",
 856          upgrade => "combine 'r' command with immediate installation",
 857         };
 858 {
 859     $autoload_recursion   ||= 0;
 860
 861     #-> sub CPAN::Shell::AUTOLOAD ;
 862     sub AUTOLOAD {
 863         $autoload_recursion++;
 864         my($l) = $AUTOLOAD;
 865         my $class = shift(@_);
 866         # warn "autoload[$l] class[$class]";
 867         $l =~ s/.*:://;
 868         if ($CPAN::Signal) {
 869             warn "Refusing to autoload '$l' while signal pending";
 870             $autoload_recursion--;
 871             return;
 872         }
 873         if ($autoload_recursion > 1) {
 874             my $fullcommand = join " ", map { "'$_'" } $l, @_;
 875             warn "Refusing to autoload $fullcommand in recursion\n";
 876             $autoload_recursion--;
 877             return;
 878         }
 879         if ($l =~ /^w/) {
 880             # XXX needs to be reconsidered
 881             if ($CPAN::META->has_inst('CPAN::WAIT')) {
 882                 CPAN::WAIT->$l(@_);
 883             } else {
 884                 $CPAN::Frontend->mywarn(qq{
 885 Commands starting with "w" require CPAN::WAIT to be installed.
 886 Please consider installing CPAN::WAIT to use the fulltext index.
 887 For this you just need to type
 888     install CPAN::WAIT
 889 });
 890             }
 891         } else {
 892             $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }.
 893                                     qq{Type ? for help.
 894 });
 895         }
 896         $autoload_recursion--;
 897     }
 898 }
 899
 900 package CPAN;
 901 use strict;
 902
 903 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
 904
 905 # from here on only subs.
 906 ################################################################################
 907
 908 sub _perl_fingerprint {
 909     my($self,$other_fingerprint) = @_;
 910     my $dll = eval {OS2::DLLname()};
 911     my $mtime_dll = 0;
 912     if (defined $dll) {
 913         $mtime_dll = (-f $dll ? (stat(_))[9] : '-1');
 914     }
 915     my $mtime_perl = (-f CPAN::find_perl ? (stat(_))[9] : '-1');
 916     my $this_fingerprint = {
 917                             '$^X' => CPAN::find_perl,
 918                             sitearchexp => $Config::Config{sitearchexp},
 919                             'mtime_$^X' => $mtime_perl,
 920                             'mtime_dll' => $mtime_dll,
 921                            };
 922     if ($other_fingerprint) {
 923         if (exists $other_fingerprint->{'stat($^X)'}) { # repair fp from rev. 1.88_57
 924             $other_fingerprint->{'mtime_$^X'} = $other_fingerprint->{'stat($^X)'}[9];
 925         }
 926         # mandatory keys since 1.88_57
 927         for my $key (qw($^X sitearchexp mtime_dll mtime_$^X)) {
 928             return unless $other_fingerprint->{$key} eq $this_fingerprint->{$key};
 929         }
 930         return 1;
 931     } else {
 932         return $this_fingerprint;
 933     }
 934 }
 935
 936 sub suggest_myconfig () {
 937   SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) {
 938         $CPAN::Frontend->myprint("You don't seem to have a user ".
 939                                  "configuration (MyConfig.pm) yet.\n");
 940         my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ".
 941                                               "user configuration now? (Y/n)",
 942                                               "yes");
 943         if($new =~ m{^y}i) {
 944             CPAN::Shell->mkmyconfig();
 945             return &checklock;
 946         } else {
 947             $CPAN::Frontend->mydie("OK, giving up.");
 948         }
 949     }
 950 }
 951
 952 #-> sub CPAN::all_objects ;
 953 sub all_objects {
 954     my($mgr,$class) = @_;
 955     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 956     CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
 957     CPAN::Index->reload;
 958     values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
 959 }
 960
 961 # Called by shell, not in batch mode. In batch mode I see no risk in
 962 # having many processes updating something as installations are
 963 # continually checked at runtime. In shell mode I suspect it is
 964 # unintentional to open more than one shell at a time
 965
 966 #-> sub CPAN::checklock ;
 967 sub checklock {
 968     my($self) = @_;
 969     my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
 970     if (-f $lockfile && -M _ > 0) {
 971         my $fh = FileHandle->new($lockfile) or
 972             $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
 973         my $otherpid  = <$fh>;
 974         my $otherhost = <$fh>;
 975         $fh->close;
 976         if (defined $otherpid && $otherpid) {
 977             chomp $otherpid;
 978         }
 979         if (defined $otherhost && $otherhost) {
 980             chomp $otherhost;
 981         }
 982         my $thishost  = hostname();
 983         if (defined $otherhost && defined $thishost &&
 984             $otherhost ne '' && $thishost ne '' &&
 985             $otherhost ne $thishost) {
 986             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
 987                                            "reports other host $otherhost and other ".
 988                                            "process $otherpid.\n".
 989                                            "Cannot proceed.\n"));
 990         } elsif ($RUN_DEGRADED) {
 991             $CPAN::Frontend->mywarn("Running in degraded mode (experimental)\n");
 992         } elsif (defined $otherpid && $otherpid) {
 993             return if $$ == $otherpid; # should never happen
 994             $CPAN::Frontend->mywarn(
 995                                     qq{
 996 There seems to be running another CPAN process (pid $otherpid).  Contacting...
 997 });
 998             if (kill 0, $otherpid) {
 999                 $CPAN::Frontend->mywarn(qq{Other job is running.\n});
1000                 my($ans) =
1001                     CPAN::Shell::colorable_makemaker_prompt
1002                         (qq{Shall I try to run in degraded }.
1003                         qq{mode? (Y/n)},"y");
1004                 if ($ans =~ /^y/i) {
1005                     $CPAN::Frontend->mywarn("Running in degraded mode (experimental).
1006 Please report if something unexpected happens\n");
1007                     $RUN_DEGRADED = 1;
1008                     for ($CPAN::Config) {
1009                         # XXX
1010                         # $_->{build_dir_reuse} = 0; # 2006-11-17 akoenig Why was that?
1011                         $_->{commandnumber_in_prompt} = 0; # visibility
1012                         $_->{histfile} = "";               # who should win otherwise?
1013                         $_->{cache_metadata} = 0;          # better would be a lock?
1014                         $_->{use_sqlite} = 0;              # better would be a write lock!
1015                     }
1016                 } else {
1017                     $CPAN::Frontend->mydie("
1018 You may want to kill the other job and delete the lockfile. On UNIX try:
1019     kill $otherpid
1020     rm $lockfile
1021 ");
1022                 }
1023             } elsif (-w $lockfile) {
1024                 my($ans) =
1025                     CPAN::Shell::colorable_makemaker_prompt
1026                         (qq{Other job not responding. Shall I overwrite }.
1027                         qq{the lockfile '$lockfile'? (Y/n)},"y");
1028             $CPAN::Frontend->myexit("Ok, bye\n")
1029                 unless $ans =~ /^y/i;
1030             } else {
1031                 Carp::croak(
1032                     qq{Lockfile '$lockfile' not writeable by you. }.
1033                     qq{Cannot proceed.\n}.
1034                     qq{    On UNIX try:\n}.
1035                     qq{    rm '$lockfile'\n}.
1036                     qq{  and then rerun us.\n}
1037                 );
1038             }
1039         } else {
1040             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Found invalid lockfile ".
1041                                            "'$lockfile', please remove. Cannot proceed.\n"));
1042         }
1043     }
1044     my $dotcpan = $CPAN::Config->{cpan_home};
1045     eval { File::Path::mkpath($dotcpan);};
1046     if ($@) {
1047         # A special case at least for Jarkko.
1048         my $firsterror = $@;
1049         my $seconderror;
1050         my $symlinkcpan;
1051         if (-l $dotcpan) {
1052             $symlinkcpan = readlink $dotcpan;
1053             die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
1054             eval { File::Path::mkpath($symlinkcpan); };
1055             if ($@) {
1056                 $seconderror = $@;
1057             } else {
1058                 $CPAN::Frontend->mywarn(qq{
1059 Working directory $symlinkcpan created.
1060 });
1061             }
1062         }
1063         unless (-d $dotcpan) {
1064             my $mess = qq{
1065 Your configuration suggests "$dotcpan" as your
1066 CPAN.pm working directory. I could not create this directory due
1067 to this error: $firsterror\n};
1068             $mess .= qq{
1069 As "$dotcpan" is a symlink to "$symlinkcpan",
1070 I tried to create that, but I failed with this error: $seconderror
1071 } if $seconderror;
1072             $mess .= qq{
1073 Please make sure the directory exists and is writable.
1074 };
1075             $CPAN::Frontend->mywarn($mess);
1076             return suggest_myconfig;
1077         }
1078     } # $@ after eval mkpath $dotcpan
1079     if (0) { # to test what happens when a race condition occurs
1080         for (reverse 1..10) {
1081             print $_, "\n";
1082             sleep 1;
1083         }
1084     }
1085     # locking
1086     if (!$RUN_DEGRADED && !$self->{LOCKFH}) {
1087         my $fh;
1088         unless ($fh = FileHandle->new("+>>$lockfile")) {
1089             if ($! =~ /Permission/) {
1090                 $CPAN::Frontend->mywarn(qq{
1091
1092 Your configuration suggests that CPAN.pm should use a working
1093 directory of
1094     $CPAN::Config->{cpan_home}
1095 Unfortunately we could not create the lock file
1096     $lockfile
1097 due to permission problems.
1098
1099 Please make sure that the configuration variable
1100     \$CPAN::Config->{cpan_home}
1101 points to a directory where you can write a .lock file. You can set
1102 this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
1103 \@INC path;
1104 });
1105                 return suggest_myconfig;
1106             }
1107         }
1108         my $sleep = 1;
1109         while (!CPAN::_flock($fh, LOCK_EX|LOCK_NB)) {
1110             if ($sleep>10) {
1111                 $CPAN::Frontend->mydie("Giving up\n");
1112             }
1113             $CPAN::Frontend->mysleep($sleep++);
1114             $CPAN::Frontend->mywarn("Could not lock lockfile with flock: $!; retrying\n");
1115         }
1116
1117         seek $fh, 0, 0;
1118         truncate $fh, 0;
1119         $fh->autoflush(1);
1120         $fh->print($$, "\n");
1121         $fh->print(hostname(), "\n");
1122         $self->{LOCK} = $lockfile;
1123         $self->{LOCKFH} = $fh;
1124     }
1125     $SIG{TERM} = sub {
1126         my $sig = shift;
1127         &cleanup;
1128         $CPAN::Frontend->mydie("Got SIG$sig, leaving");
1129     };
1130     $SIG{INT} = sub {
1131       # no blocks!!!
1132         my $sig = shift;
1133         &cleanup if $Signal;
1134         die "Got yet another signal" if $Signal > 1;
1135         $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal;
1136         $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n");
1137         $Signal++;
1138     };
1139
1140 #       From: Larry Wall <larry@wall.org>
1141 #       Subject: Re: deprecating SIGDIE
1142 #       To: perl5-porters@perl.org
1143 #       Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
1144 #
1145 #       The original intent of __DIE__ was only to allow you to substitute one
1146 #       kind of death for another on an application-wide basis without respect
1147 #       to whether you were in an eval or not.  As a global backstop, it should
1148 #       not be used any more lightly (or any more heavily :-) than class
1149 #       UNIVERSAL.  Any attempt to build a general exception model on it should
1150 #       be politely squashed.  Any bug that causes every eval {} to have to be
1151 #       modified should be not so politely squashed.
1152 #
1153 #       Those are my current opinions.  It is also my optinion that polite
1154 #       arguments degenerate to personal arguments far too frequently, and that
1155 #       when they do, it's because both people wanted it to, or at least didn't
1156 #       sufficiently want it not to.
1157 #
1158 #       Larry
1159
1160     # global backstop to cleanup if we should really die
1161     $SIG{__DIE__} = \&cleanup;
1162     $self->debug("Signal handler set.") if $CPAN::DEBUG;
1163 }
1164
1165 #-> sub CPAN::DESTROY ;
1166 sub DESTROY {
1167     &cleanup; # need an eval?
1168 }
1169
1170 #-> sub CPAN::anycwd ;
1171 sub anycwd () {
1172     my $getcwd;
1173     $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
1174     CPAN->$getcwd();
1175 }
1176
1177 #-> sub CPAN::cwd ;
1178 sub cwd {Cwd::cwd();}
1179
1180 #-> sub CPAN::getcwd ;
1181 sub getcwd {Cwd::getcwd();}
1182
1183 #-> sub CPAN::fastcwd ;
1184 sub fastcwd {Cwd::fastcwd();}
1185
1186 #-> sub CPAN::backtickcwd ;
1187 sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
1188
1189 #-> sub CPAN::find_perl ;
1190 sub find_perl () {
1191     my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
1192     my $pwd  = $CPAN::iCwd = CPAN::anycwd();
1193     my $candidate = File::Spec->catfile($pwd,$^X);
1194     $perl ||= $candidate if MM->maybe_command($candidate);
1195
1196     unless ($perl) {
1197         my ($component,$perl_name);
1198       DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
1199           PATH_COMPONENT: foreach $component (File::Spec->path(),
1200                                                 $Config::Config{'binexp'}) {
1201                 next unless defined($component) && $component;
1202                 my($abs) = File::Spec->catfile($component,$perl_name);
1203                 if (MM->maybe_command($abs)) {
1204                     $perl = $abs;
1205                     last DIST_PERLNAME;
1206                 }
1207             }
1208         }
1209     }
1210
1211     return $perl;
1212 }
1213
1214
1215 #-> sub CPAN::exists ;
1216 sub exists {
1217     my($mgr,$class,$id) = @_;
1218     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
1219     CPAN::Index->reload;
1220     ### Carp::croak "exists called without class argument" unless $class;
1221     $id ||= "";
1222     $id =~ s/:+/::/g if $class eq "CPAN::Module";
1223     my $exists;
1224     if (CPAN::_sqlite_running) {
1225         $exists = (exists $META->{readonly}{$class}{$id} or
1226                    $CPAN::SQLite->set($class, $id));
1227     } else {
1228         $exists =  exists $META->{readonly}{$class}{$id};
1229     }
1230     $exists ||= exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
1231 }
1232
1233 #-> sub CPAN::delete ;
1234 sub delete {
1235   my($mgr,$class,$id) = @_;
1236   delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
1237   delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
1238 }
1239
1240 #-> sub CPAN::has_usable
1241 # has_inst is sometimes too optimistic, we should replace it with this
1242 # has_usable whenever a case is given
1243 sub has_usable {
1244     my($self,$mod,$message) = @_;
1245     return 1 if $HAS_USABLE->{$mod};
1246     my $has_inst = $self->has_inst($mod,$message);
1247     return unless $has_inst;
1248     my $usable;
1249     $usable = {
1250                LWP => [ # we frequently had "Can't locate object
1251                         # method "new" via package "LWP::UserAgent" at
1252                         # (eval 69) line 2006
1253                        sub {require LWP},
1254                        sub {require LWP::UserAgent},
1255                        sub {require HTTP::Request},
1256                        sub {require URI::URL},
1257                       ],
1258                'Net::FTP' => [
1259                             sub {require Net::FTP},
1260                             sub {require Net::Config},
1261                            ],
1262                'File::HomeDir' => [
1263                                    sub {require File::HomeDir;
1264                                         unless (CPAN::Version->vge(File::HomeDir::->VERSION, 0.52)) {
1265                                             for ("Will not use File::HomeDir, need 0.52\n") {
1266                                                 $CPAN::Frontend->mywarn($_);
1267                                                 die $_;
1268                                             }
1269                                         }
1270                                     },
1271                                   ],
1272                'Archive::Tar' => [
1273                                   sub {require Archive::Tar;
1274                                        unless (CPAN::Version->vge(Archive::Tar::->VERSION, 1.00)) {
1275                                             for ("Will not use Archive::Tar, need 1.00\n") {
1276                                                 $CPAN::Frontend->mywarn($_);
1277                                                 die $_;
1278                                             }
1279                                        }
1280                                   },
1281                                  ],
1282                'File::Temp' => [
1283                                 # XXX we should probably delete from
1284                                 # %INC too so we can load after we
1285                                 # installed a new enough version --
1286                                 # I'm not sure.
1287                                 sub {require File::Temp;
1288                                      unless (CPAN::Version->vge(File::Temp::->VERSION,0.16)) {
1289                                          for ("Will not use File::Temp, need 0.16\n") {
1290                                                 $CPAN::Frontend->mywarn($_);
1291                                                 die $_;
1292                                          }
1293                                      }
1294                                 },
1295                                ]
1296               };
1297     if ($usable->{$mod}) {
1298         for my $c (0..$#{$usable->{$mod}}) {
1299             my $code = $usable->{$mod}[$c];
1300             my $ret = eval { &$code() };
1301             $ret = "" unless defined $ret;
1302             if ($@) {
1303                 # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
1304                 return;
1305             }
1306         }
1307     }
1308     return $HAS_USABLE->{$mod} = 1;
1309 }
1310
1311 #-> sub CPAN::has_inst
1312 sub has_inst {
1313     my($self,$mod,$message) = @_;
1314     Carp::croak("CPAN->has_inst() called without an argument")
1315         unless defined $mod;
1316     my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
1317         keys %{$CPAN::Config->{dontload_hash}||{}},
1318             @{$CPAN::Config->{dontload_list}||[]};
1319     if (defined $message && $message eq "no"  # afair only used by Nox
1320         ||
1321         $dont{$mod}
1322        ) {
1323       $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
1324       return 0;
1325     }
1326     my $file = $mod;
1327     my $obj;
1328     $file =~ s|::|/|g;
1329     $file .= ".pm";
1330     if ($INC{$file}) {
1331         # checking %INC is wrong, because $INC{LWP} may be true
1332         # although $INC{"URI/URL.pm"} may have failed. But as
1333         # I really want to say "bla loaded OK", I have to somehow
1334         # cache results.
1335         ### warn "$file in %INC"; #debug
1336         return 1;
1337     } elsif (eval { require $file }) {
1338         # eval is good: if we haven't yet read the database it's
1339         # perfect and if we have installed the module in the meantime,
1340         # it tries again. The second require is only a NOOP returning
1341         # 1 if we had success, otherwise it's retrying
1342
1343         my $mtime = (stat $INC{$file})[9];
1344         # privileged files loaded by has_inst; Note: we use $mtime
1345         # as a proxy for a checksum.
1346         $CPAN::Shell::reload->{$file} = $mtime;
1347         my $v = eval "\$$mod\::VERSION";
1348         $v = $v ? " (v$v)" : "";
1349         CPAN::Shell->optprint("load_module","CPAN: $mod loaded ok$v\n");
1350         if ($mod eq "CPAN::WAIT") {
1351             push @CPAN::Shell::ISA, 'CPAN::WAIT';
1352         }
1353         return 1;
1354     } elsif ($mod eq "Net::FTP") {
1355         $CPAN::Frontend->mywarn(qq{
1356   Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
1357   if you just type
1358       install Bundle::libnet
1359
1360 }) unless $Have_warned->{"Net::FTP"}++;
1361         $CPAN::Frontend->mysleep(3);
1362     } elsif ($mod eq "Digest::SHA") {
1363         if ($Have_warned->{"Digest::SHA"}++) {
1364             $CPAN::Frontend->mywarn(qq{CPAN: checksum security checks disabled }.
1365                                      qq{because Digest::SHA not installed.\n});
1366         } else {
1367             $CPAN::Frontend->mywarn(qq{
1368   CPAN: checksum security checks disabled because Digest::SHA not installed.
1369   Please consider installing the Digest::SHA module.
1370
1371 });
1372             $CPAN::Frontend->mysleep(2);
1373         }
1374     } elsif ($mod eq "Module::Signature") {
1375         # NOT prefs_lookup, we are not a distro
1376         my $check_sigs = $CPAN::Config->{check_sigs};
1377         if (not $check_sigs) {
1378             # they do not want us:-(
1379         } elsif (not $Have_warned->{"Module::Signature"}++) {
1380             # No point in complaining unless the user can
1381             # reasonably install and use it.
1382             if (eval { require Crypt::OpenPGP; 1 } ||
1383                 (
1384                  defined $CPAN::Config->{'gpg'}
1385                  &&
1386                  $CPAN::Config->{'gpg'} =~ /\S/
1387                 )
1388                ) {
1389                 $CPAN::Frontend->mywarn(qq{
1390   CPAN: Module::Signature security checks disabled because Module::Signature
1391   not installed.  Please consider installing the Module::Signature module.
1392   You may also need to be able to connect over the Internet to the public
1393   keyservers like pgp.mit.edu (port 11371).
1394
1395 });
1396                 $CPAN::Frontend->mysleep(2);
1397             }
1398         }
1399     } else {
1400         delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
1401     }
1402     return 0;
1403 }
1404
1405 #-> sub CPAN::instance ;
1406 sub instance {
1407     my($mgr,$class,$id) = @_;
1408     CPAN::Index->reload;
1409     $id ||= "";
1410     # unsafe meta access, ok?
1411     return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
1412     $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
1413 }
1414
1415 #-> sub CPAN::new ;
1416 sub new {
1417     bless {}, shift;
1418 }
1419
1420 #-> sub CPAN::cleanup ;
1421 sub cleanup {
1422   # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
1423   local $SIG{__DIE__} = '';
1424   my($message) = @_;
1425   my $i = 0;
1426   my $ineval = 0;
1427   my($subroutine);
1428   while ((undef,undef,undef,$subroutine) = caller(++$i)) {
1429       $ineval = 1, last if
1430         $subroutine eq '(eval)';
1431   }
1432   return if $ineval && !$CPAN::End;
1433   return unless defined $META->{LOCK};
1434   return unless -f $META->{LOCK};
1435   $META->savehist;
1436   close $META->{LOCKFH};
1437   unlink $META->{LOCK};
1438   # require Carp;
1439   # Carp::cluck("DEBUGGING");
1440   if ( $CPAN::CONFIG_DIRTY ) {
1441       $CPAN::Frontend->mywarn("Warning: Configuration not saved.\n");
1442   }
1443   $CPAN::Frontend->myprint("Lockfile removed.\n");
1444 }
1445
1446 #-> sub CPAN::readhist
1447 sub readhist {
1448     my($self,$term,$histfile) = @_;
1449     my($fh) = FileHandle->new;
1450     open $fh, "<$histfile" or last;
1451     local $/ = "\n";
1452     while (<$fh>) {
1453         chomp;
1454         $term->AddHistory($_);
1455     }
1456     close $fh;
1457 }
1458
1459 #-> sub CPAN::savehist
1460 sub savehist {
1461     my($self) = @_;
1462     my($histfile,$histsize);
1463     unless ($histfile = $CPAN::Config->{'histfile'}) {
1464         $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
1465         return;
1466     }
1467     $histsize = $CPAN::Config->{'histsize'} || 100;
1468     if ($CPAN::term) {
1469         unless ($CPAN::term->can("GetHistory")) {
1470             $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
1471             return;
1472         }
1473     } else {
1474         return;
1475     }
1476     my @h = $CPAN::term->GetHistory;
1477     splice @h, 0, @h-$histsize if @h>$histsize;
1478     my($fh) = FileHandle->new;
1479     open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
1480     local $\ = local $, = "\n";
1481     print $fh @h;
1482     close $fh;
1483 }
1484
1485 #-> sub CPAN::is_tested
1486 sub is_tested {
1487     my($self,$what,$when) = @_;
1488     unless ($what) {
1489         Carp::cluck("DEBUG: empty what");
1490         return;
1491     }
1492     $self->{is_tested}{$what} = $when;
1493 }
1494
1495 #-> sub CPAN::is_installed
1496 # unsets the is_tested flag: as soon as the thing is installed, it is
1497 # not needed in set_perl5lib anymore
1498 sub is_installed {
1499     my($self,$what) = @_;
1500     delete $self->{is_tested}{$what};
1501 }
1502
1503 sub _list_sorted_descending_is_tested {
1504     my($self) = @_;
1505     sort
1506         { ($self->{is_tested}{$b}||0) <=> ($self->{is_tested}{$a}||0) }
1507             keys %{$self->{is_tested}}
1508 }
1509
1510 #-> sub CPAN::set_perl5lib
1511 sub set_perl5lib {
1512     my($self,$for) = @_;
1513     unless ($for) {
1514         (undef,undef,undef,$for) = caller(1);
1515         $for =~ s/.*://;
1516     }
1517     $self->{is_tested} ||= {};
1518     return unless %{$self->{is_tested}};
1519     my $env = $ENV{PERL5LIB};
1520     $env = $ENV{PERLLIB} unless defined $env;
1521     my @env;
1522     push @env, $env if defined $env and length $env;
1523     #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
1524     #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
1525
1526     my @dirs = map {("$_/blib/arch", "$_/blib/lib")} $self->_list_sorted_descending_is_tested;
1527     if (@dirs < 12) {
1528         $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB for '$for'\n");
1529     } elsif (@dirs < 24) {
1530         my @d = map {my $cp = $_;
1531                      $cp =~ s/^\Q$CPAN::Config->{build_dir}\E/%BUILDDIR%/;
1532                      $cp
1533                  } @dirs;
1534         $CPAN::Frontend->myprint("Prepending @d to PERL5LIB; ".
1535                                  "%BUILDDIR%=$CPAN::Config->{build_dir} ".
1536                                  "for '$for'\n"
1537                                 );
1538     } else {
1539         my $cnt = keys %{$self->{is_tested}};
1540         $CPAN::Frontend->myprint("Prepending blib/arch and blib/lib of ".
1541                                  "$cnt build dirs to PERL5LIB; ".
1542                                  "for '$for'\n"
1543                                 );
1544     }
1545
1546     $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1547 }
1548
1549 package CPAN::CacheMgr;
1550 use strict;
1551
1552 #-> sub CPAN::CacheMgr::as_string ;
1553 sub as_string {
1554     eval { require Data::Dumper };
1555     if ($@) {
1556         return shift->SUPER::as_string;
1557     } else {
1558         return Data::Dumper::Dumper(shift);
1559     }
1560 }
1561
1562 #-> sub CPAN::CacheMgr::cachesize ;
1563 sub cachesize {
1564     shift->{DU};
1565 }
1566
1567 #-> sub CPAN::CacheMgr::tidyup ;
1568 sub tidyup {
1569   my($self) = @_;
1570   return unless $CPAN::META->{LOCK};
1571   return unless -d $self->{ID};
1572   my @toremove = grep { $self->{SIZE}{$_}==0 } @{$self->{FIFO}};
1573   for my $current (0..$#toremove) {
1574     my $toremove = $toremove[$current];
1575     $CPAN::Frontend->myprint(sprintf(
1576                                      "DEL(%d/%d): %s \n",
1577                                      $current+1,
1578                                      scalar @toremove,
1579                                      $toremove,
1580                                     )
1581                             );
1582     return if $CPAN::Signal;
1583     $self->_clean_cache($toremove);
1584     return if $CPAN::Signal;
1585   }
1586 }
1587
1588 #-> sub CPAN::CacheMgr::dir ;
1589 sub dir {
1590     shift->{ID};
1591 }
1592
1593 #-> sub CPAN::CacheMgr::entries ;
1594 sub entries {
1595     my($self,$dir) = @_;
1596     return unless defined $dir;
1597     $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
1598     $dir ||= $self->{ID};
1599     my($cwd) = CPAN::anycwd();
1600     chdir $dir or Carp::croak("Can't chdir to $dir: $!");
1601     my $dh = DirHandle->new(File::Spec->curdir)
1602         or Carp::croak("Couldn't opendir $dir: $!");
1603     my(@entries);
1604     for ($dh->read) {
1605         next if $_ eq "." || $_ eq "..";
1606         if (-f $_) {
1607             push @entries, File::Spec->catfile($dir,$_);
1608         } elsif (-d _) {
1609             push @entries, File::Spec->catdir($dir,$_);
1610         } else {
1611             $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
1612         }
1613     }
1614     chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
1615     sort { -M $a <=> -M $b} @entries;
1616 }
1617
1618 #-> sub CPAN::CacheMgr::disk_usage ;
1619 sub disk_usage {
1620     my($self,$dir,$fast) = @_;
1621     return if exists $self->{SIZE}{$dir};
1622     return if $CPAN::Signal;
1623     my($Du) = 0;
1624     if (-e $dir) {
1625         if (-d $dir) {
1626             unless (-x $dir) {
1627                 unless (chmod 0755, $dir) {
1628                     $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
1629                                             "permission to change the permission; cannot ".
1630                                             "estimate disk usage of '$dir'\n");
1631                     $CPAN::Frontend->mysleep(5);
1632                     return;
1633                 }
1634             }
1635         } elsif (-f $dir) {
1636             # nothing to say, no matter what the permissions
1637         }
1638     } else {
1639         $CPAN::Frontend->mywarn("File or directory '$dir' has gone, ignoring\n");
1640         return;
1641     }
1642     if ($fast) {
1643         $Du = 0; # placeholder
1644     } else {
1645         find(
1646              sub {
1647            $File::Find::prune++ if $CPAN::Signal;
1648            return if -l $_;
1649            if ($^O eq 'MacOS') {
1650              require Mac::Files;
1651              my $cat  = Mac::Files::FSpGetCatInfo($_);
1652              $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
1653            } else {
1654              if (-d _) {
1655                unless (-x _) {
1656                  unless (chmod 0755, $_) {
1657                    $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
1658                                            "the permission to change the permission; ".
1659                                            "can only partially estimate disk usage ".
1660                                            "of '$_'\n");
1661                    $CPAN::Frontend->mysleep(5);
1662                    return;
1663                  }
1664                }
1665              } else {
1666                $Du += (-s _);
1667              }
1668            }
1669          },
1670          $dir
1671             );
1672     }
1673     return if $CPAN::Signal;
1674     $self->{SIZE}{$dir} = $Du/1024/1024;
1675     unshift @{$self->{FIFO}}, $dir;
1676     $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
1677     $self->{DU} += $Du/1024/1024;
1678     $self->{DU};
1679 }
1680
1681 #-> sub CPAN::CacheMgr::_clean_cache ;
1682 sub _clean_cache {
1683     my($self,$dir) = @_;
1684     return unless -e $dir;
1685     unless (File::Spec->canonpath(File::Basename::dirname($dir))
1686             eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
1687         $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
1688                                 "will not remove\n");
1689         $CPAN::Frontend->mysleep(5);
1690         return;
1691     }
1692     $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
1693         if $CPAN::DEBUG;
1694     File::Path::rmtree($dir);
1695     my $id_deleted = 0;
1696     if ($dir !~ /\.yml$/ && -f "$dir.yml") {
1697         my $yaml_module = CPAN::_yaml_module;
1698         if ($CPAN::META->has_inst($yaml_module)) {
1699             my($peek_yaml) = eval { CPAN->_yaml_loadfile("$dir.yml"); };
1700             if ($@) {
1701                 $CPAN::Frontend->mywarn("(parse error on '$dir.yml' removing anyway)");
1702                 unlink "$dir.yml" or
1703                     $CPAN::Frontend->mywarn("(Could not unlink '$dir.yml': $!)");
1704                 return;
1705             } elsif (my $id = $peek_yaml->[0]{distribution}{ID}) {
1706                 $CPAN::META->delete("CPAN::Distribution", $id);
1707
1708                 # XXX we should restore the state NOW, otherise this
1709                 # distro does not exist until we read an index. BUG ALERT(?)
1710
1711                 # $CPAN::Frontend->mywarn (" +++\n");
1712                 $id_deleted++;
1713             }
1714         }
1715         unlink "$dir.yml"; # may fail
1716         unless ($id_deleted) {
1717             CPAN->debug("no distro found associated with '$dir'");
1718         }
1719     }
1720     $self->{DU} -= $self->{SIZE}{$dir};
1721     delete $self->{SIZE}{$dir};
1722 }
1723
1724 #-> sub CPAN::CacheMgr::new ;
1725 sub new {
1726     my $class = shift;
1727     my $time = time;
1728     my($debug,$t2);
1729     $debug = "";
1730     my $self = {
1731         ID => $CPAN::Config->{build_dir},
1732         MAX => $CPAN::Config->{'build_cache'},
1733         SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
1734         DU => 0
1735     };
1736     File::Path::mkpath($self->{ID});
1737     my $dh = DirHandle->new($self->{ID});
1738     bless $self, $class;
1739     $self->scan_cache;
1740     $t2 = time;
1741     $debug .= "timing of CacheMgr->new: ".($t2 - $time);
1742     $time = $t2;
1743     CPAN->debug($debug) if $CPAN::DEBUG;
1744     $self;
1745 }
1746
1747 #-> sub CPAN::CacheMgr::scan_cache ;
1748 sub scan_cache {
1749     my $self = shift;
1750     return if $self->{SCAN} eq 'never';
1751     $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
1752         unless $self->{SCAN} eq 'atstart';
1753     return unless $CPAN::META->{LOCK};
1754     $CPAN::Frontend->myprint(
1755                              sprintf("Scanning cache %s for sizes\n",
1756                              $self->{ID}));
1757     my $e;
1758     my @entries = $self->entries($self->{ID});
1759     my $i = 0;
1760     my $painted = 0;
1761     for $e (@entries) {
1762         my $symbol = ".";
1763         if ($self->{DU} > $self->{MAX}) {
1764             $symbol = "-";
1765             $self->disk_usage($e,1);
1766         } else {
1767             $self->disk_usage($e);
1768         }
1769         $i++;
1770         while (($painted/76) < ($i/@entries)) {
1771             $CPAN::Frontend->myprint($symbol);
1772             $painted++;
1773         }
1774         return if $CPAN::Signal;
1775     }
1776     $CPAN::Frontend->myprint("DONE\n");
1777     $self->tidyup;
1778 }
1779
1780 package CPAN::Shell;
1781 use strict;
1782
1783 #-> sub CPAN::Shell::h ;
1784 sub h {
1785     my($class,$about) = @_;
1786     if (defined $about) {
1787         my $help;
1788         if (exists $Help->{$about}) {
1789             if (ref $Help->{$about}) { # aliases
1790                 $about = ${$Help->{$about}};
1791             }
1792             $help = $Help->{$about};
1793         } else {
1794             $help = "No help available";
1795         }
1796         $CPAN::Frontend->myprint("$about\: $help\n");
1797     } else {
1798         my $filler = " " x (80 - 28 - length($CPAN::VERSION));
1799         $CPAN::Frontend->myprint(qq{
1800 Display Information $filler (ver $CPAN::VERSION)
1801  command  argument          description
1802  a,b,d,m  WORD or /REGEXP/  about authors, bundles, distributions, modules
1803  i        WORD or /REGEXP/  about any of the above
1804  ls       AUTHOR or GLOB    about files in the author's directory
1805     (with WORD being a module, bundle or author name or a distribution
1806     name of the form AUTHOR/DISTRIBUTION)
1807
1808 Download, Test, Make, Install...
1809  get      download                     clean    make clean
1810  make     make (implies get)           look     open subshell in dist directory
1811  test     make test (implies make)     readme   display these README files
1812  install  make install (implies test)  perldoc  display POD documentation
1813
1814 Upgrade
1815  r        WORDs or /REGEXP/ or NONE    report updates for some/matching/all modules
1816  upgrade  WORDs or /REGEXP/ or NONE    upgrade some/matching/all modules
1817
1818 Pragmas
1819  force  CMD    try hard to do command  fforce CMD    try harder
1820  notest CMD    skip testing
1821
1822 Other
1823  h,?           display this menu       ! perl-code   eval a perl command
1824  o conf [opt]  set and query options   q             quit the cpan shell
1825  reload cpan   load CPAN.pm again      reload index  load newer indices
1826  autobundle    Snapshot                recent        latest CPAN uploads});
1827 }
1828 }
1829
1830 *help = \&h;
1831
1832 #-> sub CPAN::Shell::a ;
1833 sub a {
1834   my($self,@arg) = @_;
1835   # authors are always UPPERCASE
1836   for (@arg) {
1837     $_ = uc $_ unless /=/;
1838   }
1839   $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1840 }
1841
1842 #-> sub CPAN::Shell::globls ;
1843 sub globls {
1844     my($self,$s,$pragmas) = @_;
1845     # ls is really very different, but we had it once as an ordinary
1846     # command in the Shell (upto rev. 321) and we could not handle
1847     # force well then
1848     my(@accept,@preexpand);
1849     if ($s =~ /[\*\?\/]/) {
1850         if ($CPAN::META->has_inst("Text::Glob")) {
1851             if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
1852                 my $rau = Text::Glob::glob_to_regex(uc $au);
1853                 CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
1854                       if $CPAN::DEBUG;
1855                 push @preexpand, map { $_->id . "/" . $pathglob }
1856                     CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
1857             } else {
1858                 my $rau = Text::Glob::glob_to_regex(uc $s);
1859                 push @preexpand, map { $_->id }
1860                     CPAN::Shell->expand_by_method('CPAN::Author',
1861                                                   ['id'],
1862                                                   "/$rau/");
1863             }
1864         } else {
1865             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
1866         }
1867     } else {
1868         push @preexpand, uc $s;
1869     }
1870     for (@preexpand) {
1871         unless (/^[A-Z0-9\-]+(\/|$)/i) {
1872             $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
1873             next;
1874         }
1875         push @accept, $_;
1876     }
1877     my $silent = @accept>1;
1878     my $last_alpha = "";
1879     my @results;
1880     for my $a (@accept) {
1881         my($author,$pathglob);
1882         if ($a =~ m|(.*?)/(.*)|) {
1883             my $a2 = $1;
1884             $pathglob = $2;
1885             $author = CPAN::Shell->expand_by_method('CPAN::Author',
1886                                                     ['id'],
1887                                                     $a2)
1888                 or $CPAN::Frontend->mydie("No author found for $a2\n");
1889         } else {
1890             $author = CPAN::Shell->expand_by_method('CPAN::Author',
1891                                                     ['id'],
1892                                                     $a)
1893                 or $CPAN::Frontend->mydie("No author found for $a\n");
1894         }
1895         if ($silent) {
1896             my $alpha = substr $author->id, 0, 1;
1897             my $ad;
1898             if ($alpha eq $last_alpha) {
1899                 $ad = "";
1900             } else {
1901                 $ad = "[$alpha]";
1902                 $last_alpha = $alpha;
1903             }
1904             $CPAN::Frontend->myprint($ad);
1905         }
1906         for my $pragma (@$pragmas) {
1907             if ($author->can($pragma)) {
1908                 $author->$pragma();
1909             }
1910         }
1911         push @results, $author->ls($pathglob,$silent); # silent if
1912                                                        # more than one
1913                                                        # author
1914         for my $pragma (@$pragmas) {
1915             my $unpragma = "un$pragma";
1916             if ($author->can($unpragma)) {
1917                 $author->$unpragma();
1918             }
1919         }
1920     }
1921     @results;
1922 }
1923
1924 #-> sub CPAN::Shell::local_bundles ;
1925 sub local_bundles {
1926     my($self,@which) = @_;
1927     my($incdir,$bdir,$dh);
1928     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1929         my @bbase = "Bundle";
1930         while (my $bbase = shift @bbase) {
1931             $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
1932             CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1933             if ($dh = DirHandle->new($bdir)) { # may fail
1934                 my($entry);
1935                 for $entry ($dh->read) {
1936                     next if $entry =~ /^\./;
1937                     next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/;
1938                     if (-d File::Spec->catdir($bdir,$entry)) {
1939                         push @bbase, "$bbase\::$entry";
1940                     } else {
1941                         next unless $entry =~ s/\.pm(?!\n)\Z//;
1942                         $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1943                     }
1944                 }
1945             }
1946         }
1947     }
1948 }
1949
1950 #-> sub CPAN::Shell::b ;
1951 sub b {
1952     my($self,@which) = @_;
1953     CPAN->debug("which[@which]") if $CPAN::DEBUG;
1954     $self->local_bundles;
1955     $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1956 }
1957
1958 #-> sub CPAN::Shell::d ;
1959 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1960
1961 #-> sub CPAN::Shell::m ;
1962 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1963     my $self = shift;
1964     $CPAN::Frontend->myprint($self->format_result('Module',@_));
1965 }
1966
1967 #-> sub CPAN::Shell::i ;
1968 sub i {
1969     my($self) = shift;
1970     my(@args) = @_;
1971     @args = '/./' unless @args;
1972     my(@result);
1973     for my $type (qw/Bundle Distribution Module/) {
1974         push @result, $self->expand($type,@args);
1975     }
1976     # Authors are always uppercase.
1977     push @result, $self->expand("Author", map { uc $_ } @args);
1978
1979     my $result = @result == 1 ?
1980         $result[0]->as_string :
1981             @result == 0 ?
1982                 "No objects found of any type for argument @args\n" :
1983                     join("",
1984                          (map {$_->as_glimpse} @result),
1985                          scalar @result, " items found\n",
1986                         );
1987     $CPAN::Frontend->myprint($result);
1988 }
1989
1990 #-> sub CPAN::Shell::o ;
1991
1992 # CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o
1993 # conf' calls through to CPAN::HandleConfig::edit. 'o conf' should
1994 # probably have been called 'set' and 'o debug' maybe 'set debug' or
1995 # 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm
1996 sub o {
1997     my($self,$o_type,@o_what) = @_;
1998     $o_type ||= "";
1999     CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
2000     if ($o_type eq 'conf') {
2001         my($cfilter);
2002         ($cfilter) = $o_what[0] =~ m|^/(.*)/$| if @o_what;
2003         if (!@o_what or $cfilter) { # print all things, "o conf"
2004             $cfilter ||= "";
2005             my $qrfilter = eval 'qr/$cfilter/';
2006             my($k,$v);
2007             $CPAN::Frontend->myprint("\$CPAN::Config options from ");
2008             my @from;
2009             if (exists $INC{'CPAN/Config.pm'}) {
2010                 push @from, $INC{'CPAN/Config.pm'};
2011             }
2012             if (exists $INC{'CPAN/MyConfig.pm'}) {
2013                 push @from, $INC{'CPAN/MyConfig.pm'};
2014             }
2015             $CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from);
2016             $CPAN::Frontend->myprint(":\n");
2017             for $k (sort keys %CPAN::HandleConfig::can) {
2018                 next unless $k =~ /$qrfilter/;
2019                 $v = $CPAN::HandleConfig::can{$k};
2020                 $CPAN::Frontend->myprint(sprintf "    %-18s [%s]\n", $k, $v);
2021             }
2022             $CPAN::Frontend->myprint("\n");
2023             for $k (sort keys %CPAN::HandleConfig::keys) {
2024                 next unless $k =~ /$qrfilter/;
2025                 CPAN::HandleConfig->prettyprint($k);
2026             }
2027             $CPAN::Frontend->myprint("\n");
2028         } else {
2029             if (CPAN::HandleConfig->edit(@o_what)) {
2030             } else {
2031                 $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
2032                                          qq{items\n\n});
2033             }
2034         }
2035     } elsif ($o_type eq 'debug') {
2036         my(%valid);
2037         @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
2038         if (@o_what) {
2039             while (@o_what) {
2040                 my($what) = shift @o_what;
2041                 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
2042                     $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
2043                     next;
2044                 }
2045                 if ( exists $CPAN::DEBUG{$what} ) {
2046                     $CPAN::DEBUG |= $CPAN::DEBUG{$what};
2047                 } elsif ($what =~ /^\d/) {
2048                     $CPAN::DEBUG = $what;
2049                 } elsif (lc $what eq 'all') {
2050                     my($max) = 0;
2051                     for (values %CPAN::DEBUG) {
2052                         $max += $_;
2053                     }
2054                     $CPAN::DEBUG = $max;
2055                 } else {
2056                     my($known) = 0;
2057                     for (keys %CPAN::DEBUG) {
2058                         next unless lc($_) eq lc($what);
2059                         $CPAN::DEBUG |= $CPAN::DEBUG{$_};
2060                         $known = 1;
2061                     }
2062                     $CPAN::Frontend->myprint("unknown argument [$what]\n")
2063                         unless $known;
2064                 }
2065             }
2066         } else {
2067             my $raw = "Valid options for debug are ".
2068                 join(", ",sort(keys %CPAN::DEBUG), 'all').
2069                      qq{ or a number. Completion works on the options. }.
2070                      qq{Case is ignored.};
2071             require Text::Wrap;
2072             $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
2073             $CPAN::Frontend->myprint("\n\n");
2074         }
2075         if ($CPAN::DEBUG) {
2076             $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n");
2077             my($k,$v);
2078             for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
2079                 $v = $CPAN::DEBUG{$k};
2080                 $CPAN::Frontend->myprint(sprintf "    %-14s(%s)\n", $k, $v)
2081                     if $v & $CPAN::DEBUG;
2082             }
2083         } else {
2084             $CPAN::Frontend->myprint("Debugging turned off completely.\n");
2085         }
2086     } else {
2087         $CPAN::Frontend->myprint(qq{
2088 Known options:
2089   conf    set or get configuration variables
2090   debug   set or get debugging options
2091 });
2092     }
2093 }
2094
2095 # CPAN::Shell::paintdots_onreload
2096 sub paintdots_onreload {
2097     my($ref) = shift;
2098     sub {
2099         if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
2100             my($subr) = $1;
2101             ++$$ref;
2102             local($|) = 1;
2103             # $CPAN::Frontend->myprint(".($subr)");
2104             $CPAN::Frontend->myprint(".");
2105             if ($subr =~ /\bshell\b/i) {
2106                 # warn "debug[$_[0]]";
2107
2108                 # It would be nice if we could detect that a
2109                 # subroutine has actually changed, but for now we
2110                 # practically always set the GOTOSHELL global
2111
2112                 $CPAN::GOTOSHELL=1;
2113             }
2114             return;
2115         }
2116         warn @_;
2117     };
2118 }
2119
2120 #-> sub CPAN::Shell::hosts ;
2121 sub hosts {
2122     my($self) = @_;
2123     my $fullstats = CPAN::FTP->_ftp_statistics();
2124     my $history = $fullstats->{history} || [];
2125     my %S; # statistics
2126     while (my $last = pop @$history) {
2127         my $attempts = $last->{attempts} or next;
2128         my $start;
2129         if (@$attempts) {
2130             $start = $attempts->[-1]{start};
2131             if ($#$attempts > 0) {
2132                 for my $i (0..$#$attempts-1) {
2133                     my $url = $attempts->[$i]{url} or next;
2134                     $S{no}{$url}++;
2135                 }
2136             }
2137         } else {
2138             $start = $last->{start};
2139         }
2140         next unless $last->{thesiteurl}; # C-C? bad filenames?
2141         $S{start} = $start;
2142         $S{end} ||= $last->{end};
2143         my $dltime = $last->{end} - $start;
2144         my $dlsize = $last->{filesize} || 0;
2145         my $url = ref $last->{thesiteurl} ? $last->{thesiteurl}->text : $last->{thesiteurl};
2146         my $s = $S{ok}{$url} ||= {};
2147         $s->{n}++;
2148         $s->{dlsize} ||= 0;
2149         $s->{dlsize} += $dlsize/1024;
2150         $s->{dltime} ||= 0;
2151         $s->{dltime} += $dltime;
2152     }
2153     my $res;
2154     for my $url (keys %{$S{ok}}) {
2155         next if $S{ok}{$url}{dltime} == 0; # div by zero
2156         push @{$res->{ok}}, [@{$S{ok}{$url}}{qw(n dlsize dltime)},
2157                              $S{ok}{$url}{dlsize}/$S{ok}{$url}{dltime},
2158                              $url,
2159                             ];
2160     }
2161     for my $url (keys %{$S{no}}) {
2162         push @{$res->{no}}, [$S{no}{$url},
2163                              $url,
2164                             ];
2165     }
2166     my $R = ""; # report
2167     if ($S{start} && $S{end}) {
2168         $R .= sprintf "Log starts: %s\n", $S{start} ? scalar(localtime $S{start}) : "unknown";
2169         $R .= sprintf "Log ends  : %s\n", $S{end}   ? scalar(localtime $S{end})   : "unknown";
2170     }
2171     if ($res->{ok} && @{$res->{ok}}) {
2172         $R .= sprintf "\nSuccessful downloads:
2173    N       kB  secs      kB/s url\n";
2174         my $i = 20;
2175         for (sort { $b->[3] <=> $a->[3] } @{$res->{ok}}) {
2176             $R .= sprintf "%4d %8d %5d %9.1f %s\n", @$_;
2177             last if --$i<=0;
2178         }
2179     }
2180     if ($res->{no} && @{$res->{no}}) {
2181         $R .= sprintf "\nUnsuccessful downloads:\n";
2182         my $i = 20;
2183         for (sort { $b->[0] <=> $a->[0] } @{$res->{no}}) {
2184             $R .= sprintf "%4d %s\n", @$_;
2185             last if --$i<=0;
2186         }
2187     }
2188     $CPAN::Frontend->myprint($R);
2189 }
2190
2191 #-> sub CPAN::Shell::reload ;
2192 sub reload {
2193     my($self,$command,@arg) = @_;
2194     $command ||= "";
2195     $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
2196     if ($command =~ /^cpan$/i) {
2197         my $redef = 0;
2198         chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
2199         my $failed;
2200         my @relo = (
2201                     "CPAN.pm",
2202                     "CPAN/Debug.pm",
2203                     "CPAN/FirstTime.pm",
2204                     "CPAN/HandleConfig.pm",
2205                     "CPAN/Kwalify.pm",
2206                     "CPAN/Queue.pm",
2207                     "CPAN/Reporter/Config.pm",
2208                     "CPAN/Reporter/History.pm",
2209                     "CPAN/Reporter.pm",
2210                     "CPAN/SQLite.pm",
2211                     "CPAN/Tarzip.pm",
2212                     "CPAN/Version.pm",
2213                    );
2214       MFILE: for my $f (@relo) {
2215             next unless exists $INC{$f};
2216             my $p = $f;
2217             $p =~ s/\.pm$//;
2218             $p =~ s|/|::|g;
2219             $CPAN::Frontend->myprint("($p");
2220             local($SIG{__WARN__}) = paintdots_onreload(\$redef);
2221             $self->_reload_this($f) or $failed++;
2222             my $v = eval "$p\::->VERSION";
2223             $CPAN::Frontend->myprint("v$v)");
2224         }
2225         $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
2226         if ($failed) {
2227             my $errors = $failed == 1 ? "error" : "errors";
2228             $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ".
2229                                     "this session.\n");
2230         }
2231     } elsif ($command =~ /^index$/i) {
2232       CPAN::Index->force_reload;
2233     } else {
2234       $CPAN::Frontend->myprint(qq{cpan     re-evals the CPAN modules
2235 index    re-reads the index files\n});
2236     }
2237 }
2238
2239 # reload means only load again what we have loaded before
2240 #-> sub CPAN::Shell::_reload_this ;
2241 sub _reload_this {
2242     my($self,$f,$args) = @_;
2243     CPAN->debug("f[$f]") if $CPAN::DEBUG;
2244     return 1 unless $INC{$f}; # we never loaded this, so we do not
2245                               # reload but say OK
2246     my $pwd = CPAN::anycwd();
2247     CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG;
2248     my($file);
2249     for my $inc (@INC) {
2250         $file = File::Spec->catfile($inc,split /\//, $f);
2251         last if -f $file;
2252         $file = "";
2253     }
2254     CPAN->debug("file[$file]") if $CPAN::DEBUG;
2255     my @inc = @INC;
2256     unless ($file && -f $file) {
2257         # this thingie is not in the INC path, maybe CPAN/MyConfig.pm?
2258         $file = $INC{$f};
2259         unless (CPAN->has_inst("File::Basename")) {
2260             @inc = File::Basename::dirname($file);
2261         } else {
2262             # do we ever need this?
2263             @inc = substr($file,0,-length($f)-1); # bring in back to me!
2264         }
2265     }
2266     CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG;
2267     unless (-f $file) {
2268         $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
2269         return;
2270     }
2271     my $mtime = (stat $file)[9];
2272     if ($reload->{$f}) {
2273     } elsif ($^T < $mtime) {
2274         # since we started the file has changed, force it to be reloaded
2275         $reload->{$f} = -1;
2276     } else {
2277         $reload->{$f} = $mtime;
2278     }
2279     my $must_reload = $mtime != $reload->{$f};
2280     $args ||= {};
2281     $must_reload ||= $args->{reloforce}; # o conf defaults needs this
2282     if ($must_reload) {
2283         my $fh = FileHandle->new($file) or
2284             $CPAN::Frontend->mydie("Could not open $file: $!");
2285         local($/);
2286         local $^W = 1;
2287         my $content = <$fh>;
2288         CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
2289             if $CPAN::DEBUG;
2290         delete $INC{$f};
2291         local @INC = @inc;
2292         eval "require '$f'";
2293         if ($@) {
2294             warn $@;
2295             return;
2296         }
2297         $reload->{$f} = $mtime;
2298     } else {
2299         $CPAN::Frontend->myprint("__unchanged__");
2300     }
2301     return 1;
2302 }
2303
2304 #-> sub CPAN::Shell::mkmyconfig ;
2305 sub mkmyconfig {
2306     my($self, $cpanpm, %args) = @_;
2307     require CPAN::FirstTime;
2308     my $home = CPAN::HandleConfig::home;
2309     $cpanpm = $INC{'CPAN/MyConfig.pm'} ||
2310         File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm");
2311     File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm;
2312     CPAN::HandleConfig::require_myconfig_or_config;
2313     $CPAN::Config ||= {};
2314     $CPAN::Config = {
2315         %$CPAN::Config,
2316         build_dir           =>  undef,
2317         cpan_home           =>  undef,
2318         keep_source_where   =>  undef,
2319         histfile            =>  undef,
2320     };
2321     CPAN::FirstTime::init($cpanpm, %args);
2322 }
2323
2324 #-> sub CPAN::Shell::_binary_extensions ;
2325 sub _binary_extensions {
2326     my($self) = shift @_;
2327     my(@result,$module,%seen,%need,$headerdone);
2328     for $module ($self->expand('Module','/./')) {
2329         my $file  = $module->cpan_file;
2330         next if $file eq "N/A";
2331         next if $file =~ /^Contact Author/;
2332         my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
2333         next if $dist->isa_perl;
2334         next unless $module->xs_file;
2335         local($|) = 1;
2336         $CPAN::Frontend->myprint(".");
2337         push @result, $module;
2338     }
2339 #    print join " | ", @result;
2340     $CPAN::Frontend->myprint("\n");
2341     return @result;
2342 }
2343
2344 #-> sub CPAN::Shell::recompile ;
2345 sub recompile {
2346     my($self) = shift @_;
2347     my($module,@module,$cpan_file,%dist);
2348     @module = $self->_binary_extensions();
2349     for $module (@module) { # we force now and compile later, so we
2350                             # don't do it twice
2351         $cpan_file = $module->cpan_file;
2352         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
2353         $pack->force;
2354         $dist{$cpan_file}++;
2355     }
2356     for $cpan_file (sort keys %dist) {
2357         $CPAN::Frontend->myprint("  CPAN: Recompiling $cpan_file\n\n");
2358         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
2359         $pack->install;
2360         $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
2361                            # stop a package from recompiling,
2362                            # e.g. IO-1.12 when we have perl5.003_10
2363     }
2364 }
2365
2366 #-> sub CPAN::Shell::scripts ;
2367 sub scripts {
2368     my($self, $arg) = @_;
2369     $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");
2370
2371     for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) {
2372         unless ($CPAN::META->has_inst($req)) {
2373             $CPAN::Frontend->mywarn("  $req not available\n");
2374         }
2375     }
2376     my $p = HTML::LinkExtor->new();
2377     my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html";
2378     unless (-f $indexfile) {
2379         $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n");
2380     }
2381     $p->parse_file($indexfile);
2382     my @hrefs;
2383     my $qrarg;
2384     if ($arg =~ s|^/(.+)/$|$1|) {
2385         $qrarg = eval 'qr/$arg/'; # hide construct from 5.004
2386     }
2387     for my $l ($p->links) {
2388         my $tag = shift @$l;
2389         next unless $tag eq "a";
2390         my %att = @$l;
2391         my $href = $att{href};
2392         next unless $href =~ s|^\.\./authors/id/./../||;
2393         if ($arg) {
2394             if ($qrarg) {
2395                 if ($href =~ $qrarg) {
2396                     push @hrefs, $href;
2397                 }
2398             } else {
2399                 if ($href =~ /\Q$arg\E/) {
2400                     push @hrefs, $href;
2401                 }
2402             }
2403         } else {
2404             push @hrefs, $href;
2405         }
2406     }
2407     # now filter for the latest version if there is more than one of a name
2408     my %stems;
2409     for (sort @hrefs) {
2410         my $href = $_;
2411         s/-v?\d.*//;
2412         my $stem = $_;
2413         $stems{$stem} ||= [];
2414         push @{$stems{$stem}}, $href;
2415     }
2416     for (sort keys %stems) {
2417         my $highest;
2418         if (@{$stems{$_}} > 1) {
2419             $highest = List::Util::reduce {
2420                 Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b
2421               } @{$stems{$_}};
2422         } else {
2423             $highest = $stems{$_}[0];
2424         }
2425         $CPAN::Frontend->myprint("$highest\n");
2426     }
2427 }
2428
2429 #-> sub CPAN::Shell::report ;
2430 sub report {
2431     my($self,@args) = @_;
2432     unless ($CPAN::META->has_inst("CPAN::Reporter")) {
2433         $CPAN::Frontend->mydie("CPAN::Reporter not installed; cannot continue");
2434     }
2435     local $CPAN::Config->{test_report} = 1;
2436     $self->force("test",@args); # force is there so that the test be
2437                                 # re-run (as documented)
2438 }
2439
2440 # compare with is_tested
2441 #-> sub CPAN::Shell::install_tested
2442 sub install_tested {
2443     my($self,@some) = @_;
2444     $CPAN::Frontend->mywarn("install_tested() must not be called with arguments.\n"),
2445         return if @some;
2446     CPAN::Index->reload;
2447
2448     for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
2449         my $yaml = "$b.yml";
2450         unless (-f $yaml) {
2451             $CPAN::Frontend->mywarn("No YAML file for $b available, skipping\n");
2452             next;
2453         }
2454         my $yaml_content = CPAN->_yaml_loadfile($yaml);
2455         my $id = $yaml_content->[0]{distribution}{ID};
2456         unless ($id) {
2457             $CPAN::Frontend->mywarn("No ID found in '$yaml', skipping\n");
2458             next;
2459         }
2460         my $do = CPAN::Shell->expandany($id);
2461         unless ($do) {
2462             $CPAN::Frontend->mywarn("Could not expand ID '$id', skipping\n");
2463             next;
2464         }
2465         unless ($do->{build_dir}) {
2466             $CPAN::Frontend->mywarn("Distro '$id' has no build_dir, skipping\n");
2467             next;
2468         }
2469         unless ($do->{build_dir} eq $b) {
2470             $CPAN::Frontend->mywarn("Distro '$id' has build_dir '$do->{build_dir}' but expected '$b', skipping\n");
2471             next;
2472         }
2473         push @some, $do;
2474     }
2475
2476     $CPAN::Frontend->mywarn("No tested distributions found.\n"),
2477         return unless @some;
2478
2479     @some = grep { $_->{make_test} && ! $_->{make_test}->failed } @some;
2480     $CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"),
2481         return unless @some;
2482
2483     # @some = grep { not $_->uptodate } @some;
2484     # $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"),
2485     #     return unless @some;
2486
2487     CPAN->debug("some[@some]");
2488     for my $d (@some) {
2489         my $id = $d->can("pretty_id") ? $d->pretty_id : $d->id;
2490         $CPAN::Frontend->myprint("install_tested: Running for $id\n");
2491         $CPAN::Frontend->mysleep(1);
2492         $self->install($d);
2493     }
2494 }
2495
2496 #-> sub CPAN::Shell::upgrade ;
2497 sub upgrade {
2498     my($self,@args) = @_;
2499     $self->install($self->r(@args));
2500 }
2501
2502 #-> sub CPAN::Shell::_u_r_common ;
2503 sub _u_r_common {
2504     my($self) = shift @_;
2505     my($what) = shift @_;
2506     CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
2507     Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
2508           $what && $what =~ /^[aru]$/;
2509     my(@args) = @_;
2510     @args = '/./' unless @args;
2511     my(@result,$module,%seen,%need,$headerdone,
2512        $version_undefs,$version_zeroes,
2513        @version_undefs,@version_zeroes);
2514     $version_undefs = $version_zeroes = 0;
2515     my $sprintf = "%s%-25s%s %9s %9s  %s\n";
2516     my @expand = $self->expand('Module',@args);
2517     my $expand = scalar @expand;
2518     if (0) { # Looks like noise to me, was very useful for debugging
2519              # for metadata cache
2520         $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
2521     }
2522   MODULE: for $module (@expand) {
2523         my $file  = $module->cpan_file;
2524         next MODULE unless defined $file; # ??
2525         $file =~ s!^./../!!;
2526         my($latest) = $module->cpan_version;
2527         my($inst_file) = $module->inst_file;
2528         my($have);
2529         return if $CPAN::Signal;
2530         if ($inst_file) {
2531             if ($what eq "a") {
2532                 $have = $module->inst_version;
2533             } elsif ($what eq "r") {
2534                 $have = $module->inst_version;
2535                 local($^W) = 0;
2536                 if ($have eq "undef") {
2537                     $version_undefs++;
2538                     push @version_undefs, $module->as_glimpse;
2539                 } elsif (CPAN::Version->vcmp($have,0)==0) {
2540                     $version_zeroes++;
2541                     push @version_zeroes, $module->as_glimpse;
2542                 }
2543                 next MODULE unless CPAN::Version->vgt($latest, $have);
2544 # to be pedantic we should probably say:
2545 #    && !($have eq "undef" && $latest ne "undef" && $latest gt "");
2546 # to catch the case where CPAN has a version 0 and we have a version undef
2547             } elsif ($what eq "u") {
2548                 next MODULE;
2549             }
2550         } else {
2551             if ($what eq "a") {
2552                 next MODULE;
2553             } elsif ($what eq "r") {
2554                 next MODULE;
2555             } elsif ($what eq "u") {
2556                 $have = "-";
2557             }
2558         }
2559         return if $CPAN::Signal; # this is sometimes lengthy
2560         $seen{$file} ||= 0;
2561         if ($what eq "a") {
2562             push @result, sprintf "%s %s\n", $module->id, $have;
2563         } elsif ($what eq "r") {
2564             push @result, $module->id;
2565             next MODULE if $seen{$file}++;
2566         } elsif ($what eq "u") {
2567             push @result, $module->id;
2568             next MODULE if $seen{$file}++;
2569             next MODULE if $file =~ /^Contact/;
2570         }
2571         unless ($headerdone++) {
2572             $CPAN::Frontend->myprint("\n");
2573             $CPAN::Frontend->myprint(sprintf(
2574                                              $sprintf,
2575                                              "",
2576                                              "Package namespace",
2577                                              "",
2578                                              "installed",
2579                                              "latest",
2580                                              "in CPAN file"
2581                                             ));
2582         }
2583         my $color_on = "";
2584         my $color_off = "";
2585         if (
2586             $COLOR_REGISTERED
2587             &&
2588             $CPAN::META->has_inst("Term::ANSIColor")
2589             &&
2590             $module->description
2591            ) {
2592             $color_on = Term::ANSIColor::color("green");
2593             $color_off = Term::ANSIColor::color("reset");
2594         }
2595         $CPAN::Frontend->myprint(sprintf $sprintf,
2596                                  $color_on,
2597                                  $module->id,
2598                                  $color_off,
2599                                  $have,
2600                                  $latest,
2601                                  $file);
2602         $need{$module->id}++;
2603     }
2604     unless (%need) {
2605         if ($what eq "u") {
2606             $CPAN::Frontend->myprint("No modules found for @args\n");
2607         } elsif ($what eq "r") {
2608             $CPAN::Frontend->myprint("All modules are up to date for @args\n");
2609         }
2610     }
2611     if ($what eq "r") {
2612         if ($version_zeroes) {
2613             my $s_has = $version_zeroes > 1 ? "s have" : " has";
2614             $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
2615                                      qq{a version number of 0\n});
2616             if ($CPAN::Config->{show_zero_versions}) {
2617                 local $" = "\t";
2618                 $CPAN::Frontend->myprint(qq{  they are\n\t@version_zeroes\n});
2619                 $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 0' }.
2620                                          qq{to hide them)\n});
2621             } else {
2622                 $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 1' }.
2623                                          qq{to show them)\n});
2624             }
2625         }
2626         if ($version_undefs) {
2627             my $s_has = $version_undefs > 1 ? "s have" : " has";
2628             $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
2629                                      qq{parseable version number\n});
2630             if ($CPAN::Config->{show_unparsable_versions}) {
2631                 local $" = "\t";
2632                 $CPAN::Frontend->myprint(qq{  they are\n\t@version_undefs\n});
2633                 $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 0' }.
2634                                          qq{to hide them)\n});
2635             } else {
2636                 $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 1' }.
2637                                          qq{to show them)\n});
2638             }
2639         }
2640     }
2641     @result;
2642 }
2643
2644 #-> sub CPAN::Shell::r ;
2645 sub r {
2646     shift->_u_r_common("r",@_);
2647 }
2648
2649 #-> sub CPAN::Shell::u ;
2650 sub u {
2651     shift->_u_r_common("u",@_);
2652 }
2653
2654 #-> sub CPAN::Shell::failed ;
2655 sub failed {
2656     my($self,$only_id,$silent) = @_;
2657     my @failed;
2658   DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
2659         my $failed = "";
2660       NAY: for my $nosayer ( # order matters!
2661                             "unwrapped",
2662                             "writemakefile",
2663                             "signature_verify",
2664                             "make",
2665                             "make_test",
2666                             "install",
2667                             "make_clean",
2668                            ) {
2669             next unless exists $d->{$nosayer};
2670             next unless defined $d->{$nosayer};
2671             next unless (
2672                          UNIVERSAL::can($d->{$nosayer},"failed") ?
2673                          $d->{$nosayer}->failed :
2674                          $d->{$nosayer} =~ /^NO/
2675                         );
2676             next NAY if $only_id && $only_id != (
2677                                                  UNIVERSAL::can($d->{$nosayer},"commandid")
2678                                                  ?
2679                                                  $d->{$nosayer}->commandid
2680                                                  :
2681                                                  $CPAN::CurrentCommandId
2682                                                 );
2683             $failed = $nosayer;
2684             last;
2685         }
2686         next DIST unless $failed;
2687         my $id = $d->id;
2688         $id =~ s|^./../||;
2689         #$print .= sprintf(
2690         #                  "  %-45s: %s %s\n",
2691         push @failed,
2692             (
2693              UNIVERSAL::can($d->{$failed},"failed") ?
2694              [
2695               $d->{$failed}->commandid,
2696               $id,
2697               $failed,
2698               $d->{$failed}->text,
2699               $d->{$failed}{TIME}||0,
2700              ] :
2701              [
2702               1,
2703               $id,
2704               $failed,
2705               $d->{$failed},
2706               0,
2707              ]
2708             );
2709     }
2710     my $scope;
2711     if ($only_id) {
2712         $scope = "this command";
2713     } elsif ($CPAN::Index::HAVE_REANIMATED) {
2714         $scope = "this or a previous session";
2715         # it might be nice to have a section for previous session and
2716         # a second for this
2717     } else {
2718         $scope = "this session";
2719     }
2720     if (@failed) {
2721         my $print;
2722         my $debug = 0;
2723         if ($debug) {
2724             $print = join "",
2725                 map { sprintf "%5d %-45s: %s %s\n", @$_ }
2726                     sort { $a->[0] <=> $b->[0] } @failed;
2727         } else {
2728             $print = join "",
2729                 map { sprintf " %-45s: %s %s\n", @$_[1..3] }
2730                     sort {
2731                         $a->[0] <=> $b->[0]
2732                             ||
2733                                 $a->[4] <=> $b->[4]
2734                        } @failed;
2735         }
2736         $CPAN::Frontend->myprint("Failed during $scope:\n$print");
2737     } elsif (!$only_id || !$silent) {
2738         $CPAN::Frontend->myprint("Nothing failed in $scope\n");
2739     }
2740 }
2741
2742 # XXX intentionally undocumented because completely bogus, unportable,
2743 # useless, etc.
2744
2745 #-> sub CPAN::Shell::status ;
2746 sub status {
2747     my($self) = @_;
2748     require Devel::Size;
2749     my $ps = FileHandle->new;
2750     open $ps, "/proc/$$/status";
2751     my $vm = 0;
2752     while (<$ps>) {
2753         next unless /VmSize:\s+(\d+)/;
2754         $vm = $1;
2755         last;
2756     }
2757     $CPAN::Frontend->mywarn(sprintf(
2758                                     "%-27s %6d\n%-27s %6d\n",
2759                                     "vm",
2760                                     $vm,
2761                                     "CPAN::META",
2762                                     Devel::Size::total_size($CPAN::META)/1024,
2763                                    ));
2764     for my $k (sort keys %$CPAN::META) {
2765         next unless substr($k,0,4) eq "read";
2766         warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
2767         for my $k2 (sort keys %{$CPAN::META->{$k}}) {
2768             warn sprintf "  %-25s %6d (keys: %6d)\n",
2769                 $k2,
2770                     Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
2771                           scalar keys %{$CPAN::META->{$k}{$k2}};
2772         }
2773     }
2774 }
2775
2776 # compare with install_tested
2777 #-> sub CPAN::Shell::is_tested
2778 sub is_tested {
2779     my($self) = @_;
2780     CPAN::Index->reload;
2781     for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
2782         my $time;
2783         if ($CPAN::META->{is_tested}{$b}) {
2784             $time = scalar(localtime $CPAN::META->{is_tested}{$b});
2785         } else {
2786             $time = scalar localtime;
2787             $time =~ s/\S/?/g;
2788         }
2789         $CPAN::Frontend->myprint(sprintf "%s %s\n", $time, $b);
2790     }
2791 }
2792
2793 #-> sub CPAN::Shell::autobundle ;
2794 sub autobundle {
2795     my($self) = shift;
2796     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
2797     my(@bundle) = $self->_u_r_common("a",@_);
2798     my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
2799     File::Path::mkpath($todir);
2800     unless (-d $todir) {
2801         $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
2802         return;
2803     }
2804     my($y,$m,$d) =  (localtime)[5,4,3];
2805     $y+=1900;
2806     $m++;
2807     my($c) = 0;
2808     my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
2809     my($to) = File::Spec->catfile($todir,"$me.pm");
2810     while (-f $to) {
2811         $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
2812         $to = File::Spec->catfile($todir,"$me.pm");
2813     }
2814     my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
2815     $fh->print(
2816                "package Bundle::$me;\n\n",
2817                "\$VERSION = '0.01';\n\n",
2818                "1;\n\n",
2819                "__END__\n\n",
2820                "=head1 NAME\n\n",
2821                "Bundle::$me - Snapshot of installation on ",
2822                $Config::Config{'myhostname'},
2823                " on ",
2824                scalar(localtime),
2825                "\n\n=head1 SYNOPSIS\n\n",
2826                "perl -MCPAN -e 'install Bundle::$me'\n\n",
2827                "=head1 CONTENTS\n\n",
2828                join("\n", @bundle),
2829                "\n\n=head1 CONFIGURATION\n\n",
2830                Config->myconfig,
2831                "\n\n=head1 AUTHOR\n\n",
2832                "This Bundle has been generated automatically ",
2833                "by the autobundle routine in CPAN.pm.\n",
2834               );
2835     $fh->close;
2836     $CPAN::Frontend->myprint("\nWrote bundle file
2837     $to\n\n");
2838 }
2839
2840 #-> sub CPAN::Shell::expandany ;
2841 sub expandany {
2842     my($self,$s) = @_;
2843     CPAN->debug("s[$s]") if $CPAN::DEBUG;
2844     if ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory
2845         $s = CPAN::Distribution->normalize($s);
2846         return $CPAN::META->instance('CPAN::Distribution',$s);
2847         # Distributions spring into existence, not expand
2848     } elsif ($s =~ m|^Bundle::|) {
2849         $self->local_bundles; # scanning so late for bundles seems
2850                               # both attractive and crumpy: always
2851                               # current state but easy to forget
2852                               # somewhere
2853         return $self->expand('Bundle',$s);
2854     } else {
2855         return $self->expand('Module',$s)
2856             if $CPAN::META->exists('CPAN::Module',$s);
2857     }
2858     return;
2859 }
2860
2861 #-> sub CPAN::Shell::expand ;
2862 sub expand {
2863     my $self = shift;
2864     my($type,@args) = @_;
2865     CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
2866     my $class = "CPAN::$type";
2867     my $methods = ['id'];
2868     for my $meth (qw(name)) {
2869         next unless $class->can($meth);
2870         push @$methods, $meth;
2871     }
2872     $self->expand_by_method($class,$methods,@args);
2873 }
2874
2875 #-> sub CPAN::Shell::expand_by_method ;
2876 sub expand_by_method {
2877     my $self = shift;
2878     my($class,$methods,@args) = @_;
2879     my($arg,@m);
2880     for $arg (@args) {
2881         my($regex,$command);
2882         if ($arg =~ m|^/(.*)/$|) {
2883             $regex = $1;
2884 # FIXME:  there seem to be some ='s in the author data, which trigger
2885 #         a failure here.  This needs to be contemplated.
2886 #            } elsif ($arg =~ m/=/) {
2887 #                $command = 1;
2888         }
2889         my $obj;
2890         CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
2891                     $class,
2892                     defined $regex ? $regex : "UNDEFINED",
2893                     defined $command ? $command : "UNDEFINED",
2894                    ) if $CPAN::DEBUG;
2895         if (defined $regex) {
2896             if (CPAN::_sqlite_running) {
2897                 $CPAN::SQLite->search($class, $regex);
2898             }
2899             for $obj (
2900                       $CPAN::META->all_objects($class)
2901                      ) {
2902                 unless ($obj && UNIVERSAL::can($obj,"id") && $obj->id) {
2903                     # BUG, we got an empty object somewhere
2904                     require Data::Dumper;
2905                     CPAN->debug(sprintf(
2906                                         "Bug in CPAN: Empty id on obj[%s][%s]",
2907                                         $obj,
2908                                         Data::Dumper::Dumper($obj)
2909                                        )) if $CPAN::DEBUG;
2910                     next;
2911                 }
2912                 for my $method (@$methods) {
2913                     my $match = eval {$obj->$method() =~ /$regex/i};
2914                     if ($@) {
2915                         my($err) = $@ =~ /^(.+) at .+? line \d+\.$/;
2916                         $err ||= $@; # if we were too restrictive above
2917                         $CPAN::Frontend->mydie("$err\n");
2918                     } elsif ($match) {
2919                         push @m, $obj;
2920                         last;
2921                     }
2922                 }
2923             }
2924         } elsif ($command) {
2925             die "equal sign in command disabled (immature interface), ".
2926                 "you can set
2927  ! \$CPAN::Shell::ADVANCED_QUERY=1
2928 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
2929 that may go away anytime.\n"
2930                     unless $ADVANCED_QUERY;
2931             my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
2932             my($matchcrit) = $criterion =~ m/^~(.+)/;
2933             for my $self (
2934                           sort
2935                           {$a->id cmp $b->id}
2936                           $CPAN::META->all_objects($class)
2937                          ) {
2938                 my $lhs = $self->$method() or next; # () for 5.00503
2939                 if ($matchcrit) {
2940                     push @m, $self if $lhs =~ m/$matchcrit/;
2941                 } else {
2942                     push @m, $self if $lhs eq $criterion;
2943                 }
2944             }
2945         } else {
2946             my($xarg) = $arg;
2947             if ( $class eq 'CPAN::Bundle' ) {
2948                 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
2949             } elsif ($class eq "CPAN::Distribution") {
2950                 $xarg = CPAN::Distribution->normalize($arg);
2951             } else {
2952                 $xarg =~ s/:+/::/g;
2953             }
2954             if ($CPAN::META->exists($class,$xarg)) {
2955                 $obj = $CPAN::META->instance($class,$xarg);
2956             } elsif ($CPAN::META->exists($class,$arg)) {
2957                 $obj = $CPAN::META->instance($class,$arg);
2958             } else {
2959                 next;
2960             }
2961             push @m, $obj;
2962         }
2963     }
2964     @m = sort {$a->id cmp $b->id} @m;
2965     if ( $CPAN::DEBUG ) {
2966         my $wantarray = wantarray;
2967         my $join_m = join ",", map {$_->id} @m;
2968         $self->debug("wantarray[$wantarray]join_m[$join_m]");
2969     }
2970     return wantarray ? @m : $m[0];
2971 }
2972
2973 #-> sub CPAN::Shell::format_result ;
2974 sub format_result {
2975     my($self) = shift;
2976     my($type,@args) = @_;
2977     @args = '/./' unless @args;
2978     my(@result) = $self->expand($type,@args);
2979     my $result = @result == 1 ?
2980         $result[0]->as_string :
2981             @result == 0 ?
2982                 "No objects of type $type found for argument @args\n" :
2983                     join("",
2984                          (map {$_->as_glimpse} @result),
2985                          scalar @result, " items found\n",
2986                         );
2987     $result;
2988 }
2989
2990 #-> sub CPAN::Shell::report_fh ;
2991 {
2992     my $installation_report_fh;
2993     my $previously_noticed = 0;
2994
2995     sub report_fh {
2996         return $installation_report_fh if $installation_report_fh;
2997         if ($CPAN::META->has_usable("File::Temp")) {
2998             $installation_report_fh
2999                 = File::Temp->new(
3000                                   dir      => File::Spec->tmpdir,
3001                                   template => 'cpan_install_XXXX',
3002                                   suffix   => '.txt',
3003                                   unlink   => 0,
3004                                  );
3005         }
3006         unless ( $installation_report_fh ) {
3007             warn("Couldn't open installation report file; " .
3008                  "no report file will be generated."
3009                 ) unless $previously_noticed++;
3010         }
3011     }
3012 }
3013
3014
3015 # The only reason for this method is currently to have a reliable
3016 # debugging utility that reveals which output is going through which
3017 # channel. No, I don't like the colors ;-)
3018
3019 # to turn colordebugging on, write
3020 # cpan> o conf colorize_output 1
3021
3022 #-> sub CPAN::Shell::print_ornamented ;
3023 {
3024     my $print_ornamented_have_warned = 0;
3025     sub colorize_output {
3026         my $colorize_output = $CPAN::Config->{colorize_output};
3027         if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
3028             unless ($print_ornamented_have_warned++) {
3029                 # no myprint/mywarn within myprint/mywarn!
3030                 warn "Colorize_output is set to true but Term::ANSIColor is not
3031 installed. To activate colorized output, please install Term::ANSIColor.\n\n";
3032             }
3033             $colorize_output = 0;
3034         }
3035         return $colorize_output;
3036     }
3037 }
3038
3039
3040 #-> sub CPAN::Shell::print_ornamented ;
3041 sub print_ornamented {
3042     my($self,$what,$ornament) = @_;
3043     return unless defined $what;
3044
3045     local $| = 1; # Flush immediately
3046     if ( $CPAN::Be_Silent ) {
3047         print {report_fh()} $what;
3048         return;
3049     }
3050     my $swhat = "$what"; # stringify if it is an object
3051     if ($CPAN::Config->{term_is_latin}) {
3052         # note: deprecated, need to switch to $LANG and $LC_*
3053         # courtesy jhi:
3054         $swhat
3055             =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
3056     }
3057     if ($self->colorize_output) {
3058         if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
3059             # if you want to have this configurable, please file a bugreport
3060             $ornament = $CPAN::Config->{colorize_debug} || "black on_cyan";
3061         }
3062         my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
3063         if ($@) {
3064             print "Term::ANSIColor rejects color[$ornament]: $@\n
3065 Please choose a different color (Hint: try 'o conf init /color/')\n";
3066         }
3067         # GGOLDBACH/Test-GreaterVersion-0.008 broke wthout this
3068         # $trailer construct. We want the newline be the last thing if
3069         # there is a newline at the end ensuring that the next line is
3070         # empty for other players
3071         my $trailer = "";
3072         $trailer = $1 if $swhat =~ s/([\r\n]+)\z//;
3073         print $color_on,
3074             $swhat,
3075                 Term::ANSIColor::color("reset"),
3076                       $trailer;
3077     } else {
3078         print $swhat;
3079     }
3080 }
3081
3082 #-> sub CPAN::Shell::myprint ;
3083
3084 # where is myprint/mywarn/Frontend/etc. documented? Where to use what?
3085 # I think, we send everything to STDOUT and use print for normal/good
3086 # news and warn for news that need more attention. Yes, this is our
3087 # working contract for now.
3088 sub myprint {
3089     my($self,$what) = @_;
3090     $self->print_ornamented($what,
3091                             $CPAN::Config->{colorize_print}||'bold blue on_white',
3092                            );
3093 }
3094
3095 sub optprint {
3096     my($self,$category,$what) = @_;
3097     my $vname = $category . "_verbosity";
3098     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
3099     if (!$CPAN::Config->{$vname}
3100         || $CPAN::Config->{$vname} =~ /^v/
3101        ) {
3102         $CPAN::Frontend->myprint($what);
3103     }
3104 }
3105
3106 #-> sub CPAN::Shell::myexit ;
3107 sub myexit {
3108     my($self,$what) = @_;
3109     $self->myprint($what);
3110     exit;
3111 }
3112
3113 #-> sub CPAN::Shell::mywarn ;
3114 sub mywarn {
3115     my($self,$what) = @_;
3116     $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
3117 }
3118
3119 # only to be used for shell commands
3120 #-> sub CPAN::Shell::mydie ;
3121 sub mydie {
3122     my($self,$what) = @_;
3123     $self->mywarn($what);
3124
3125     # If it is the shell, we want the following die to be silent,
3126     # but if it is not the shell, we would need a 'die $what'. We need
3127     # to take care that only shell commands use mydie. Is this
3128     # possible?
3129
3130     die "\n";
3131 }
3132
3133 # sub CPAN::Shell::colorable_makemaker_prompt ;
3134 sub colorable_makemaker_prompt {
3135     my($foo,$bar) = @_;
3136     if (CPAN::Shell->colorize_output) {
3137         my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
3138         my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
3139         print $color_on;
3140     }
3141     my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
3142     if (CPAN::Shell->colorize_output) {
3143         print Term::ANSIColor::color('reset');
3144     }
3145     return $ans;
3146 }
3147
3148 # use this only for unrecoverable errors!
3149 #-> sub CPAN::Shell::unrecoverable_error ;
3150 sub unrecoverable_error {
3151     my($self,$what) = @_;
3152     my @lines = split /\n/, $what;
3153     my $longest = 0;
3154     for my $l (@lines) {
3155         $longest = length $l if length $l > $longest;
3156     }
3157     $longest = 62 if $longest > 62;
3158     for my $l (@lines) {
3159         if ($l =~ /^\s*$/) {
3160             $l = "\n";
3161             next;
3162         }
3163         $l = "==> $l";
3164         if (length $l < 66) {
3165             $l = pack "A66 A*", $l, "<==";
3166         }
3167         $l .= "\n";
3168     }
3169     unshift @lines, "\n";
3170     $self->mydie(join "", @lines);
3171 }
3172
3173 #-> sub CPAN::Shell::mysleep ;
3174 sub mysleep {
3175     my($self, $sleep) = @_;
3176     if (CPAN->has_inst("Time::HiRes")) {
3177         Time::HiRes::sleep($sleep);
3178     } else {
3179         sleep($sleep < 1 ? 1 : int($sleep + 0.5));
3180     }
3181 }
3182
3183 #-> sub CPAN::Shell::setup_output ;
3184 sub setup_output {
3185     return if -t STDOUT;
3186     my $odef = select STDERR;
3187     $| = 1;
3188     select STDOUT;
3189     $| = 1;
3190     select $odef;
3191 }
3192
3193 #-> sub CPAN::Shell::rematein ;
3194 # RE-adme||MA-ke||TE-st||IN-stall : nearly everything runs through here
3195 sub rematein {
3196     my $self = shift;
3197     my($meth,@some) = @_;
3198     my @pragma;
3199     while($meth =~ /^(ff?orce|notest)$/) {
3200         push @pragma, $meth;
3201         $meth = shift @some or
3202             $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
3203                                    "cannot continue");
3204     }
3205     setup_output();
3206     CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
3207
3208     # Here is the place to set "test_count" on all involved parties to
3209     # 0. We then can pass this counter on to the involved
3210     # distributions and those can refuse to test if test_count > X. In
3211     # the first stab at it we could use a 1 for "X".
3212
3213     # But when do I reset the distributions to start with 0 again?
3214     # Jost suggested to have a random or cycling interaction ID that
3215     # we pass through. But the ID is something that is just left lying
3216     # around in addition to the counter, so I'd prefer to set the
3217     # counter to 0 now, and repeat at the end of the loop. But what
3218     # about dependencies? They appear later and are not reset, they
3219     # enter the queue but not its copy. How do they get a sensible
3220     # test_count?
3221
3222     # With configure_requires, "get" is vulnerable in recursion.
3223
3224     my $needs_recursion_protection = "get|make|test|install";
3225
3226     # construct the queue
3227     my($s,@s,@qcopy);
3228   STHING: foreach $s (@some) {
3229         my $obj;
3230         if (ref $s) {
3231             CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
3232             $obj = $s;
3233         } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
3234         } elsif ($s =~ m|^/|) { # looks like a regexp
3235             if (substr($s,-1,1) eq ".") {
3236                 $obj = CPAN::Shell->expandany($s);
3237             } else {
3238                 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
3239                                         "not supported.\nRejecting argument '$s'\n");
3240                 $CPAN::Frontend->mysleep(2);
3241                 next;
3242             }
3243         } elsif ($meth eq "ls") {
3244             $self->globls($s,\@pragma);
3245             next STHING;
3246         } else {
3247             CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
3248             $obj = CPAN::Shell->expandany($s);
3249         }
3250         if (0) {
3251         } elsif (ref $obj) {
3252             if ($meth =~ /^($needs_recursion_protection)$/) {
3253                 # it would be silly to check for recursion for look or dump
3254                 # (we are in CPAN::Shell::rematein)
3255                 CPAN->debug("Going to test against recursion") if $CPAN::DEBUG;
3256                 eval {  $obj->color_cmd_tmps(0,1); };
3257                 if ($@) {
3258                     if (ref $@
3259                         and $@->isa("CPAN::Exception::RecursiveDependency")) {
3260                         $CPAN::Frontend->mywarn($@);
3261                     } else {
3262                         if (0) {
3263                             require Carp;
3264                             Carp::confess(sprintf "DEBUG: \$\@[%s]ref[%s]", $@, ref $@);
3265                         }
3266                         die;
3267                     }
3268                 }
3269             }
3270             CPAN::Queue->queue_item(qmod => $obj->id, reqtype => "c");
3271             push @qcopy, $obj;
3272         } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
3273             $obj = $CPAN::META->instance('CPAN::Author',uc($s));
3274             if ($meth =~ /^(dump|ls|reports)$/) {
3275                 $obj->$meth();
3276             } else {
3277                 $CPAN::Frontend->mywarn(
3278                                         join "",
3279                                         "Don't be silly, you can't $meth ",
3280                                         $obj->fullname,
3281                                         " ;-)\n"
3282                                        );
3283                 $CPAN::Frontend->mysleep(2);
3284             }
3285         } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
3286             CPAN::InfoObj->dump($s);
3287         } else {
3288             $CPAN::Frontend
3289                 ->mywarn(qq{Warning: Cannot $meth $s, }.
3290                          qq{don't know what it is.
3291 Try the command
3292
3293     i /$s/
3294
3295 to find objects with matching identifiers.
3296 });
3297             $CPAN::Frontend->mysleep(2);
3298         }
3299     }
3300
3301     # queuerunner (please be warned: when I started to change the
3302     # queue to hold objects instead of names, I made one or two
3303     # mistakes and never found which. I reverted back instead)
3304     while (my $q = CPAN::Queue->first) {
3305         my $obj;
3306         my $s = $q->as_string;
3307         my $reqtype = $q->reqtype || "";
3308         $obj = CPAN::Shell->expandany($s);
3309         unless ($obj) {
3310             # don't know how this can happen, maybe we should panic,
3311             # but maybe we get a solution from the first user who hits
3312             # this unfortunate exception?
3313             $CPAN::Frontend->mywarn("Warning: Could not expand string '$s' ".
3314                                     "to an object. Skipping.\n");
3315             $CPAN::Frontend->mysleep(5);
3316             CPAN::Queue->delete_first($s);
3317             next;
3318         }
3319         $obj->{reqtype} ||= "";
3320         {
3321             # force debugging because CPAN::SQLite somehow delivers us
3322             # an empty object;
3323
3324             # local $CPAN::DEBUG = 1024; # Shell; probably fixed now
3325
3326             CPAN->debug("s[$s]obj-reqtype[$obj->{reqtype}]".
3327                         "q-reqtype[$reqtype]") if $CPAN::DEBUG;
3328         }
3329         if ($obj->{reqtype}) {
3330             if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
3331                 $obj->{reqtype} = $reqtype;
3332                 if (
3333                     exists $obj->{install}
3334                     &&
3335                     (
3336                      UNIVERSAL::can($obj->{install},"failed") ?
3337                      $obj->{install}->failed :
3338                      $obj->{install} =~ /^NO/
3339                     )
3340                    ) {
3341                     delete $obj->{install};
3342                     $CPAN::Frontend->mywarn
3343                         ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
3344                 }
3345             }
3346         } else {
3347             $obj->{reqtype} = $reqtype;
3348         }
3349
3350         for my $pragma (@pragma) {
3351             if ($pragma
3352                 &&
3353                 $obj->can($pragma)) {
3354                 $obj->$pragma($meth);
3355             }
3356         }
3357         if (UNIVERSAL::can($obj, 'called_for')) {
3358             $obj->called_for($s);
3359         }
3360         CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
3361                     qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
3362
3363         push @qcopy, $obj;
3364         if ($meth =~ /^(report)$/) { # they came here with a pragma?
3365             $self->$meth($obj);
3366         } elsif (! UNIVERSAL::can($obj,$meth)) {
3367             # Must never happen
3368             my $serialized = "";
3369             if (0) {
3370             } elsif ($CPAN::META->has_inst("YAML::Syck")) {
3371                 $serialized = YAML::Syck::Dump($obj);
3372             } elsif ($CPAN::META->has_inst("YAML")) {
3373                 $serialized = YAML::Dump($obj);
3374             } elsif ($CPAN::META->has_inst("Data::Dumper")) {
3375                 $serialized = Data::Dumper::Dumper($obj);
3376             } else {
3377                 require overload;
3378                 $serialized = overload::StrVal($obj);
3379             }
3380             CPAN->debug("Going to panic. meth[$meth]s[$s]") if $CPAN::DEBUG;
3381             $CPAN::Frontend->mydie("Panic: obj[$serialized] cannot meth[$meth]");
3382         } elsif ($obj->$meth()) {
3383             CPAN::Queue->delete($s);
3384             CPAN->debug("From queue deleted. meth[$meth]s[$s]") if $CPAN::DEBUG;
3385         } else {
3386             CPAN->debug("Failed. pragma[@pragma]meth[$meth]") if $CPAN::DEBUG;
3387         }
3388
3389         $obj->undelay;
3390         for my $pragma (@pragma) {
3391             my $unpragma = "un$pragma";
3392             if ($obj->can($unpragma)) {
3393                 $obj->$unpragma();
3394             }
3395         }
3396         CPAN::Queue->delete_first($s);
3397     }
3398     if ($meth =~ /^($needs_recursion_protection)$/) {
3399         for my $obj (@qcopy) {
3400             $obj->color_cmd_tmps(0,0);
3401         }
3402     }
3403 }
3404
3405 #-> sub CPAN::Shell::recent ;
3406 sub recent {
3407   my($self) = @_;
3408   if ($CPAN::META->has_inst("XML::LibXML")) {
3409       my $url = $CPAN::Defaultrecent;
3410       $CPAN::Frontend->myprint("Going to fetch '$url'\n");
3411       unless ($CPAN::META->has_usable("LWP")) {
3412           $CPAN::Frontend->mydie("LWP not installed; cannot continue");
3413       }
3414       CPAN::LWP::UserAgent->config;
3415       my $Ua;
3416       eval { $Ua = CPAN::LWP::UserAgent->new; };
3417       if ($@) {
3418           $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
3419       }
3420       my $resp = $Ua->get($url);
3421       unless ($resp->is_success) {
3422           $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
3423       }
3424       $CPAN::Frontend->myprint("DONE\n\n");
3425       my $xml = XML::LibXML->new->parse_string($resp->content);
3426       if (0) {
3427           my $s = $xml->serialize(2);
3428           $s =~ s/\n\s*\n/\n/g;
3429           $CPAN::Frontend->myprint($s);
3430           return;
3431       }
3432       my @distros;
3433       if ($url =~ /winnipeg/) {
3434           my $pubdate = $xml->findvalue("/rss/channel/pubDate");
3435           $CPAN::Frontend->myprint("    pubDate: $pubdate\n\n");
3436           for my $eitem ($xml->findnodes("/rss/channel/item")) {
3437               my $distro = $eitem->findvalue("enclosure/\@url");
3438               $distro =~ s|.*?/authors/id/./../||;
3439               my $size   = $eitem->findvalue("enclosure/\@length");
3440               my $desc   = $eitem->findvalue("description");
3441 \0              $desc =~ s/.+? - //;
3442               $CPAN::Frontend->myprint("$distro [$size b]\n    $desc\n");
3443               push @distros, $distro;
3444           }
3445       } elsif ($url =~ /search.*uploads.rdf/) {
3446           # xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
3447           # xmlns="http://purl.org/rss/1.0/"
3448           # xmlns:taxo="http://purl.org/rss/1.0/modules/taxonomy/"
3449           # xmlns:dc="http://purl.org/dc/elements/1.1/"
3450           # xmlns:syn="http://purl.org/rss/1.0/modules/syndication/"
3451           # xmlns:admin="http://webns.net/mvcb/"
3452
3453
3454           my $dc_date = $xml->findvalue("//*[local-name(.) = 'RDF']/*[local-name(.) = 'channel']/*[local-name(.) = 'date']");
3455           $CPAN::Frontend->myprint("    dc:date: $dc_date\n\n");
3456           my $finish_eitem = 0;
3457           local $SIG{INT} = sub { $finish_eitem = 1 };
3458         EITEM: for my $eitem ($xml->findnodes("//*[local-name(.) = 'RDF']/*[local-name(.) = 'item']")) {
3459               my $distro = $eitem->findvalue("\@rdf:about");
3460               $distro =~ s|.*~||; # remove up to the tilde before the name
3461               $distro =~ s|/$||; # remove trailing slash
3462               $distro =~ s|([^/]+)|\U$1\E|; # upcase the name
3463               my $author = uc $1 or die "distro[$distro] without author, cannot continue";
3464               my $desc   = $eitem->findvalue("*[local-name(.) = 'description']");
3465               my $i = 0;
3466             SUBDIRTEST: while () {
3467                   last SUBDIRTEST if ++$i >= 6; # half a dozen must do!
3468                   if (my @ret = $self->globls("$distro*")) {
3469                       @ret = grep {$_->[2] !~ /meta/} @ret;
3470                       @ret = grep {length $_->[2]} @ret;
3471                       if (@ret) {
3472                           $distro = "$author/$ret[0][2]";
3473                           last SUBDIRTEST;
3474                       }
3475                   }
3476                   $distro =~ s|/|/*/|; # allow it to reside in a subdirectory
3477               }
3478
3479               next EITEM if $distro =~ m|\*|; # did not find the thing
3480               $CPAN::Frontend->myprint("____$desc\n");
3481               push @distros, $distro;
3482               last EITEM if $finish_eitem;
3483           }
3484       }
3485       return \@distros;
3486   } else {
3487       # deprecated old version
3488       $CPAN::Frontend->mydie("no XML::LibXML installed, cannot continue\n");
3489   }
3490 }
3491
3492 #-> sub CPAN::Shell::smoke ;
3493 sub smoke {
3494     my($self) = @_;
3495     my $distros = $self->recent;
3496   DISTRO: for my $distro (@$distros) {
3497         $CPAN::Frontend->myprint(sprintf "Going to download and test '$distro'\n");
3498         {
3499             my $skip = 0;
3500             local $SIG{INT} = sub { $skip = 1 };
3501             for (0..9) {
3502                 $CPAN::Frontend->myprint(sprintf "\r%2d (Hit ^C to skip)", 10-$_);
3503                 sleep 1;
3504                 if ($skip) {
3505                     $CPAN::Frontend->myprint(" skipped\n");
3506                     next DISTRO;
3507                 }
3508             }
3509         }
3510         $CPAN::Frontend->myprint("\r  \n"); # leave the dirty line with a newline
3511         $self->test($distro);
3512     }
3513 }
3514
3515 {
3516     # set up the dispatching methods
3517     no strict "refs";
3518     for my $command (qw(
3519                         clean
3520                         cvs_import
3521                         dump
3522                         force
3523                         fforce
3524                         get
3525                         install
3526                         look
3527                         ls
3528                         make
3529                         notest
3530                         perldoc
3531                         readme
3532                         reports
3533                         test
3534                        )) {
3535         *$command = sub { shift->rematein($command, @_); };
3536     }
3537 }
3538
3539 package CPAN::LWP::UserAgent;
3540 use strict;
3541
3542 sub config {
3543     return if $SETUPDONE;
3544     if ($CPAN::META->has_usable('LWP::UserAgent')) {
3545         require LWP::UserAgent;
3546         @ISA = qw(Exporter LWP::UserAgent);
3547         $SETUPDONE++;
3548     } else {
3549         $CPAN::Frontend->mywarn("  LWP::UserAgent not available\n");
3550     }
3551 }
3552
3553 sub get_basic_credentials {
3554     my($self, $realm, $uri, $proxy) = @_;
3555     if ($USER && $PASSWD) {
3556         return ($USER, $PASSWD);
3557     }
3558     if ( $proxy ) {
3559         ($USER,$PASSWD) = $self->get_proxy_credentials();
3560     } else {
3561         ($USER,$PASSWD) = $self->get_non_proxy_credentials();
3562     }
3563     return($USER,$PASSWD);
3564 }
3565
3566 sub get_proxy_credentials {
3567     my $self = shift;
3568     my ($user, $password);
3569     if ( defined $CPAN::Config->{proxy_user} &&
3570          defined $CPAN::Config->{proxy_pass}) {
3571         $user = $CPAN::Config->{proxy_user};
3572         $password = $CPAN::Config->{proxy_pass};
3573         return ($user, $password);
3574     }
3575     my $username_prompt = "\nProxy authentication needed!
3576  (Note: to permanently configure username and password run
3577    o conf proxy_user your_username
3578    o conf proxy_pass your_password
3579      )\nUsername:";
3580     ($user, $password) =
3581         _get_username_and_password_from_user($username_prompt);
3582     return ($user,$password);
3583 }
3584
3585 sub get_non_proxy_credentials {
3586     my $self = shift;
3587     my ($user,$password);
3588     if ( defined $CPAN::Config->{username} &&
3589          defined $CPAN::Config->{password}) {
3590         $user = $CPAN::Config->{username};
3591         $password = $CPAN::Config->{password};
3592         return ($user, $password);
3593     }
3594     my $username_prompt = "\nAuthentication needed!
3595      (Note: to permanently configure username and password run
3596        o conf username your_username
3597        o conf password your_password
3598      )\nUsername:";
3599
3600     ($user, $password) =
3601         _get_username_and_password_from_user($username_prompt);
3602     return ($user,$password);
3603 }
3604
3605 sub _get_username_and_password_from_user {
3606     my $username_message = shift;
3607     my ($username,$password);
3608
3609     ExtUtils::MakeMaker->import(qw(prompt));
3610     $username = prompt($username_message);
3611         if ($CPAN::META->has_inst("Term::ReadKey")) {
3612             Term::ReadKey::ReadMode("noecho");
3613         }
3614     else {
3615         $CPAN::Frontend->mywarn(
3616             "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"
3617         );
3618     }
3619     $password = prompt("Password:");
3620
3621         if ($CPAN::META->has_inst("Term::ReadKey")) {
3622             Term::ReadKey::ReadMode("restore");
3623         }
3624         $CPAN::Frontend->myprint("\n\n");
3625     return ($username,$password);
3626 }
3627
3628 # mirror(): Its purpose is to deal with proxy authentication. When we
3629 # call SUPER::mirror, we relly call the mirror method in
3630 # LWP::UserAgent. LWP::UserAgent will then call
3631 # $self->get_basic_credentials or some equivalent and this will be
3632 # $self->dispatched to our own get_basic_credentials method.
3633
3634 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3635
3636 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3637 # although we have gone through our get_basic_credentials, the proxy
3638 # server refuses to connect. This could be a case where the username or
3639 # password has changed in the meantime, so I'm trying once again without
3640 # $USER and $PASSWD to give the get_basic_credentials routine another
3641 # chance to set $USER and $PASSWD.
3642
3643 # mirror(): Its purpose is to deal with proxy authentication. When we
3644 # call SUPER::mirror, we relly call the mirror method in
3645 # LWP::UserAgent. LWP::UserAgent will then call
3646 # $self->get_basic_credentials or some equivalent and this will be
3647 # $self->dispatched to our own get_basic_credentials method.
3648
3649 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3650
3651 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3652 # although we have gone through our get_basic_credentials, the proxy
3653 # server refuses to connect. This could be a case where the username or
3654 # password has changed in the meantime, so I'm trying once again without
3655 # $USER and $PASSWD to give the get_basic_credentials routine another
3656 # chance to set $USER and $PASSWD.
3657
3658 sub mirror {
3659     my($self,$url,$aslocal) = @_;
3660     my $result = $self->SUPER::mirror($url,$aslocal);
3661     if ($result->code == 407) {
3662         undef $USER;
3663         undef $PASSWD;
3664         $result = $self->SUPER::mirror($url,$aslocal);
3665     }
3666     $result;
3667 }
3668
3669 package CPAN::FTP;
3670 use strict;
3671
3672 #-> sub CPAN::FTP::ftp_statistics
3673 # if they want to rewrite, they need to pass in a filehandle
3674 sub _ftp_statistics {
3675     my($self,$fh) = @_;
3676     my $locktype = $fh ? LOCK_EX : LOCK_SH;
3677     $fh ||= FileHandle->new;
3678     my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3679     open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!");
3680     my $sleep = 1;
3681     my $waitstart;
3682     while (!CPAN::_flock($fh, $locktype|LOCK_NB)) {
3683         $waitstart ||= localtime();
3684         if ($sleep>3) {
3685             $CPAN::Frontend->mywarn("Waiting for a read lock on '$file' (since $waitstart)\n");
3686         }
3687         $CPAN::Frontend->mysleep($sleep);
3688         if ($sleep <= 3) {
3689             $sleep+=0.33;
3690         } elsif ($sleep <=6) {
3691             $sleep+=0.11;
3692         }
3693     }
3694     my $stats = eval { CPAN->_yaml_loadfile($file); };
3695     if ($@) {
3696         if (ref $@) {
3697             if (ref $@ eq "CPAN::Exception::yaml_not_installed") {
3698                 $CPAN::Frontend->myprint("Warning (usually harmless): $@");
3699                 return;
3700             } elsif (ref $@ eq "CPAN::Exception::yaml_process_error") {
3701                 $CPAN::Frontend->mydie($@);
3702             }
3703         } else {
3704             $CPAN::Frontend->mydie($@);
3705         }
3706     }
3707     return $stats->[0];
3708 }
3709
3710 #-> sub CPAN::FTP::_mytime
3711 sub _mytime () {
3712     if (CPAN->has_inst("Time::HiRes")) {
3713         return Time::HiRes::time();
3714     } else {
3715         return time;
3716     }
3717 }
3718
3719 #-> sub CPAN::FTP::_new_stats
3720 sub _new_stats {
3721     my($self,$file) = @_;
3722     my $ret = {
3723                file => $file,
3724                attempts => [],
3725                start => _mytime,
3726               };
3727     $ret;
3728 }
3729
3730 #-> sub CPAN::FTP::_add_to_statistics
3731 sub _add_to_statistics {
3732     my($self,$stats) = @_;
3733     my $yaml_module = CPAN::_yaml_module;
3734     $self->debug("yaml_module[$yaml_module]") if $CPAN::DEBUG;
3735     if ($CPAN::META->has_inst($yaml_module)) {
3736         $stats->{thesiteurl} = $ThesiteURL;
3737         if (CPAN->has_inst("Time::HiRes")) {
3738             $stats->{end} = Time::HiRes::time();
3739         } else {
3740             $stats->{end} = time;
3741         }
3742         my $fh = FileHandle->new;
3743         my $time = time;
3744         my $sdebug = 0;
3745         my @debug;
3746         @debug = $time if $sdebug;
3747         my $fullstats = $self->_ftp_statistics($fh);
3748         close $fh;
3749         $fullstats->{history} ||= [];
3750         push @debug, scalar @{$fullstats->{history}} if $sdebug;
3751         push @debug, time if $sdebug;
3752         push @{$fullstats->{history}}, $stats;
3753         # arbitrary hardcoded constants until somebody demands to have
3754         # them settable; YAML.pm 0.62 is unacceptably slow with 999;
3755         # YAML::Syck 0.82 has no noticable performance problem with 999;
3756         while (
3757                @{$fullstats->{history}} > 99
3758                || $time - $fullstats->{history}[0]{start} > 14*86400
3759               ) {
3760             shift @{$fullstats->{history}}
3761         }
3762         push @debug, scalar @{$fullstats->{history}} if $sdebug;
3763         push @debug, time if $sdebug;
3764         push @debug, scalar localtime($fullstats->{history}[0]{start}) if $sdebug;
3765         # need no eval because if this fails, it is serious
3766         my $sfile = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3767         CPAN->_yaml_dumpfile("$sfile.$$",$fullstats);
3768         if ( $sdebug ) {
3769             local $CPAN::DEBUG = 512; # FTP
3770             push @debug, time;
3771             CPAN->debug(sprintf("DEBUG history: before_read[%d]before[%d]at[%d]".
3772                                 "after[%d]at[%d]oldest[%s]dumped backat[%d]",
3773                                 @debug,
3774                                ));
3775         }
3776         # Win32 cannot rename a file to an existing filename
3777         unlink($sfile) if ($^O eq 'MSWin32');
3778         rename "$sfile.$$", $sfile
3779             or $CPAN::Frontend->mydie("Could not rename '$sfile.$$' to '$sfile': $!\n");
3780     }
3781 }
3782
3783 # if file is CHECKSUMS, suggest the place where we got the file to be
3784 # checked from, maybe only for young files?
3785 #-> sub CPAN::FTP::_recommend_url_for
3786 sub _recommend_url_for {
3787     my($self, $file) = @_;
3788     my $urllist = $self->_get_urllist;
3789     if ($file =~ s|/CHECKSUMS(.gz)?$||) {
3790         my $fullstats = $self->_ftp_statistics();
3791         my $history = $fullstats->{history} || [];
3792         while (my $last = pop @$history) {
3793             last if $last->{end} - time > 3600; # only young results are interesting
3794             next unless $last->{file}; # dirname of nothing dies!
3795             next unless $file eq File::Basename::dirname($last->{file});
3796             return $last->{thesiteurl};
3797         }
3798     }
3799     if ($CPAN::Config->{randomize_urllist}
3800         &&
3801         rand(1) < $CPAN::Config->{randomize_urllist}
3802        ) {
3803         $urllist->[int rand scalar @$urllist];
3804     } else {
3805         return ();
3806     }
3807 }
3808
3809 #-> sub CPAN::FTP::_get_urllist
3810 sub _get_urllist {
3811     my($self) = @_;
3812     $CPAN::Config->{urllist} ||= [];
3813     unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
3814         $CPAN::Frontend->mywarn("Malformed urllist; ignoring.  Configuration file corrupt?\n");
3815         $CPAN::Config->{urllist} = [];
3816     }
3817     my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}};
3818     for my $u (@urllist) {
3819         CPAN->debug("u[$u]") if $CPAN::DEBUG;
3820         if (UNIVERSAL::can($u,"text")) {
3821             $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
3822         } else {
3823             $u .= "/" unless substr($u,-1) eq "/";
3824             $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
3825         }
3826     }
3827     \@urllist;
3828 }
3829
3830 #-> sub CPAN::FTP::ftp_get ;
3831 sub ftp_get {
3832     my($class,$host,$dir,$file,$target) = @_;
3833     $class->debug(
3834                   qq[Going to fetch file [$file] from dir [$dir]
3835         on host [$host] as local [$target]\n]
3836                  ) if $CPAN::DEBUG;
3837     my $ftp = Net::FTP->new($host);
3838     unless ($ftp) {
3839         $CPAN::Frontend->mywarn("  Could not connect to host '$host' with Net::FTP\n");
3840         return;
3841     }
3842     return 0 unless defined $ftp;
3843     $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
3844     $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
3845     unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ) {
3846         my $msg = $ftp->message;
3847         $CPAN::Frontend->mywarn("  Couldn't login on $host: $msg");
3848         return;
3849     }
3850     unless ( $ftp->cwd($dir) ) {
3851         my $msg = $ftp->message;
3852         $CPAN::Frontend->mywarn("  Couldn't cwd $dir: $msg");
3853         return;
3854     }
3855     $ftp->binary;
3856     $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
3857     unless ( $ftp->get($file,$target) ) {
3858         my $msg = $ftp->message;
3859         $CPAN::Frontend->mywarn("  Couldn't fetch $file from $host: $msg");
3860         return;
3861     }
3862     $ftp->quit; # it's ok if this fails
3863     return 1;
3864 }
3865
3866 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
3867
3868  # > *** /install/perl/live/lib/CPAN.pm-        Wed Sep 24 13:08:48 1997
3869  # > --- /tmp/cp        Wed Sep 24 13:26:40 1997
3870  # > ***************
3871  # > *** 1562,1567 ****
3872  # > --- 1562,1580 ----
3873  # >       return 1 if substr($url,0,4) eq "file";
3874  # >       return 1 unless $url =~ m|://([^/]+)|;
3875  # >       my $host = $1;
3876  # > +     my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
3877  # > +     if ($proxy) {
3878  # > +         $proxy =~ m|://([^/:]+)|;
3879  # > +         $proxy = $1;
3880  # > +         my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
3881  # > +         if ($noproxy) {
3882  # > +             if ($host !~ /$noproxy$/) {
3883  # > +                 $host = $proxy;
3884  # > +             }
3885  # > +         } else {
3886  # > +             $host = $proxy;
3887  # > +         }
3888  # > +     }
3889  # >       require Net::Ping;
3890  # >       return 1 unless $Net::Ping::VERSION >= 2;
3891  # >       my $p;
3892
3893
3894 #-> sub CPAN::FTP::localize ;
3895 sub localize {
3896     my($self,$file,$aslocal,$force) = @_;
3897     $force ||= 0;
3898     Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
3899         unless defined $aslocal;
3900     $self->debug("file[$file] aslocal[$aslocal] force[$force]")
3901         if $CPAN::DEBUG;
3902
3903     if ($^O eq 'MacOS') {
3904         # Comment by AK on 2000-09-03: Uniq short filenames would be
3905         # available in CHECKSUMS file
3906         my($name, $path) = File::Basename::fileparse($aslocal, '');
3907         if (length($name) > 31) {
3908             $name =~ s/(
3909                         \.(
3910                            readme(\.(gz|Z))? |
3911                            (tar\.)?(gz|Z) |
3912                            tgz |
3913                            zip |
3914                            pm\.(gz|Z)
3915                           )
3916                        )$//x;
3917             my $suf = $1;
3918             my $size = 31 - length($suf);
3919             while (length($name) > $size) {
3920                 chop $name;
3921             }
3922             $name .= $suf;
3923             $aslocal = File::Spec->catfile($path, $name);
3924         }
3925     }
3926
3927     if (-f $aslocal && -r _ && !($force & 1)) {
3928         my $size;
3929         if ($size = -s $aslocal) {
3930             $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
3931             return $aslocal;
3932         } else {
3933             # empty file from a previous unsuccessful attempt to download it
3934             unlink $aslocal or
3935                 $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
3936                                        "could not remove.");
3937         }
3938     }
3939     my($maybe_restore) = 0;
3940     if (-f $aslocal) {
3941         rename $aslocal, "$aslocal.bak$$";
3942         $maybe_restore++;
3943     }
3944
3945     my($aslocal_dir) = File::Basename::dirname($aslocal);
3946     $self->mymkpath($aslocal_dir); # too early for file URLs / RT #28438
3947     # Inheritance is not easier to manage than a few if/else branches
3948     if ($CPAN::META->has_usable('LWP::UserAgent')) {
3949         unless ($Ua) {
3950             CPAN::LWP::UserAgent->config;
3951             eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
3952             if ($@) {
3953                 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
3954                     if $CPAN::DEBUG;
3955             } else {
3956                 my($var);
3957                 $Ua->proxy('ftp',  $var)
3958                     if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
3959                 $Ua->proxy('http', $var)
3960                     if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
3961                 $Ua->no_proxy($var)
3962                     if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
3963             }
3964         }
3965     }
3966     for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
3967         $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
3968     }
3969
3970     # Try the list of urls for each single object. We keep a record
3971     # where we did get a file from
3972     my(@reordered,$last);
3973     my $ccurllist = $self->_get_urllist;
3974     $last = $#$ccurllist;
3975     if ($force & 2) { # local cpans probably out of date, don't reorder
3976         @reordered = (0..$last);
3977     } else {
3978         @reordered =
3979             sort {
3980                 (substr($ccurllist->[$b],0,4) eq "file")
3981                     <=>
3982                 (substr($ccurllist->[$a],0,4) eq "file")
3983                     or
3984                 defined($ThesiteURL)
3985                     and
3986                 ($ccurllist->[$b] eq $ThesiteURL)
3987                     <=>
3988                 ($ccurllist->[$a] eq $ThesiteURL)
3989             } 0..$last;
3990     }
3991     my(@levels);
3992     $Themethod ||= "";
3993     $self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG;
3994     my @all_levels = (
3995                       ["dleasy",   "file"],
3996                       ["dleasy"],
3997                       ["dlhard"],
3998                       ["dlhardest"],
3999                       ["dleasy",   "http","defaultsites"],
4000                       ["dlhard",   "http","defaultsites"],
4001                       ["dleasy",   "ftp", "defaultsites"],
4002                       ["dlhard",   "ftp", "defaultsites"],
4003                       ["dlhardest","",    "defaultsites"],
4004                      );
4005     if ($Themethod) {
4006         @levels = grep {$_->[0] eq $Themethod} @all_levels;
4007         push @levels, grep {$_->[0] ne $Themethod} @all_levels;
4008     } else {
4009         @levels = @all_levels;
4010     }
4011     @levels = qw/dleasy/ if $^O eq 'MacOS';
4012     my($levelno);
4013     local $ENV{FTP_PASSIVE} =
4014         exists $CPAN::Config->{ftp_passive} ?
4015         $CPAN::Config->{ftp_passive} : 1;
4016     my $ret;
4017     my $stats = $self->_new_stats($file);
4018   LEVEL: for $levelno (0..$#levels) {
4019         my $level_tuple = $levels[$levelno];
4020         my($level,$scheme,$sitetag) = @$level_tuple;
4021         my $defaultsites = $sitetag && $sitetag eq "defaultsites";
4022         my @urllist;
4023         if ($defaultsites) {
4024             unless (defined $connect_to_internet_ok) {
4025                 $CPAN::Frontend->myprint(sprintf qq{
4026 I would like to connect to one of the following sites to get '%s':
4027
4028 %s
4029 },
4030                                          $file,
4031                                          join("",map { " ".$_->text."\n" } @CPAN::Defaultsites),
4032                                         );
4033                 my $answer = CPAN::Shell::colorable_makemaker_prompt("Is it OK to try to connect to the Internet?", "yes");
4034                 if ($answer =~ /^y/i) {
4035                     $connect_to_internet_ok = 1;
4036                 } else {
4037                     $connect_to_internet_ok = 0;
4038                 }
4039             }
4040             if ($connect_to_internet_ok) {
4041                 @urllist = @CPAN::Defaultsites;
4042             } else {
4043                 @urllist = ();
4044             }
4045         } else {
4046             my @host_seq = $level =~ /dleasy/ ?
4047                 @reordered : 0..$last;  # reordered has file and $Thesiteurl first
4048             @urllist = map { $ccurllist->[$_] } @host_seq;
4049         }
4050         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
4051         my $aslocal_tempfile = $aslocal . ".tmp" . $$;
4052         if (my $recommend = $self->_recommend_url_for($file)) {
4053             @urllist = grep { $_ ne $recommend } @urllist;
4054             unshift @urllist, $recommend;
4055         }
4056         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
4057         $ret = $self->hostdlxxx($level,$scheme,\@urllist,$file,$aslocal_tempfile,$stats);
4058         if ($ret) {
4059             CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG;
4060             if ($ret eq $aslocal_tempfile) {
4061                 # if we got it exactly as we asked for, only then we
4062                 # want to rename
4063                 rename $aslocal_tempfile, $aslocal
4064                     or $CPAN::Frontend->mydie("Error while trying to rename ".
4065                                               "'$ret' to '$aslocal': $!");
4066                 $ret = $aslocal;
4067             }
4068             $Themethod = $level;
4069             my $now = time;
4070             # utime $now, $now, $aslocal; # too bad, if we do that, we
4071                                           # might alter a local mirror
4072             $self->debug("level[$level]") if $CPAN::DEBUG;
4073             last LEVEL;
4074         } else {
4075             unlink $aslocal_tempfile;
4076             last if $CPAN::Signal; # need to cleanup
4077         }
4078     }
4079     if ($ret) {
4080         $stats->{filesize} = -s $ret;
4081     }
4082     $self->debug("before _add_to_statistics") if $CPAN::DEBUG;
4083     $self->_add_to_statistics($stats);
4084     $self->debug("after _add_to_statistics") if $CPAN::DEBUG;
4085     if ($ret) {
4086         unlink "$aslocal.bak$$";
4087         return $ret;
4088     }
4089     unless ($CPAN::Signal) {
4090         my(@mess);
4091         local $" = " ";
4092         if (@{$CPAN::Config->{urllist}}) {
4093             push @mess,
4094                 qq{Please check, if the URLs I found in your configuration file \(}.
4095                     join(", ", @{$CPAN::Config->{urllist}}).
4096                         qq{\) are valid.};
4097         } else {
4098             push @mess, qq{Your urllist is empty!};
4099         }
4100         push @mess, qq{The urllist can be edited.},
4101             qq{E.g. with 'o conf urllist push ftp://myurl/'};
4102         $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
4103         $CPAN::Frontend->mywarn("Could not fetch $file\n");
4104         $CPAN::Frontend->mysleep(2);
4105     }
4106     if ($maybe_restore) {
4107         rename "$aslocal.bak$$", $aslocal;
4108         $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
4109                                  $self->ls($aslocal));
4110         return $aslocal;
4111     }
4112     return;
4113 }
4114
4115 sub mymkpath {
4116     my($self, $aslocal_dir) = @_;
4117     File::Path::mkpath($aslocal_dir);
4118     $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
4119                             qq{directory "$aslocal_dir".
4120     I\'ll continue, but if you encounter problems, they may be due
4121     to insufficient permissions.\n}) unless -w $aslocal_dir;
4122 }
4123
4124 sub hostdlxxx {
4125     my $self = shift;
4126     my $level = shift;
4127     my $scheme = shift;
4128     my $h = shift;
4129     $h = [ grep /^\Q$scheme\E:/, @$h ] if $scheme;
4130     my $method = "host$level";
4131     $self->$method($h, @_);
4132 }
4133
4134 sub _set_attempt {
4135     my($self,$stats,$method,$url) = @_;
4136     push @{$stats->{attempts}}, {
4137                                  method => $method,
4138                                  start => _mytime,
4139                                  url => $url,
4140                                 };
4141 }
4142
4143 # package CPAN::FTP;
4144 sub hostdleasy {
4145     my($self,$host_seq,$file,$aslocal,$stats) = @_;
4146     my($ro_url);
4147   HOSTEASY: for $ro_url (@$host_seq) {
4148         $self->_set_attempt($stats,"dleasy",$ro_url);
4149         my $url .= "$ro_url$file";
4150         $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
4151         if ($url =~ /^file:/) {
4152             my $l;
4153             if ($CPAN::META->has_inst('URI::URL')) {
4154                 my $u =  URI::URL->new($url);
4155                 $l = $u->path;
4156             } else { # works only on Unix, is poorly constructed, but
4157                 # hopefully better than nothing.
4158                 # RFC 1738 says fileurl BNF is
4159                 # fileurl = "file://" [ host | "localhost" ] "/" fpath
4160                 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
4161                 # the code
4162                 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
4163                 $l =~ s|^file:||;                   # assume they
4164                                                     # meant
4165                                                     # file://localhost
4166                 $l =~ s|^/||s
4167                     if ! -f $l && $l =~ m|^/\w:|;   # e.g. /P:
4168             }
4169             $self->debug("local file[$l]") if $CPAN::DEBUG;
4170             if ( -f $l && -r _) {
4171                 $ThesiteURL = $ro_url;
4172                 return $l;
4173             }
4174             if ($l =~ /(.+)\.gz$/) {
4175                 my $ungz = $1;
4176                 if ( -f $ungz && -r _) {
4177                     $ThesiteURL = $ro_url;
4178                     return $ungz;
4179                 }
4180             }
4181             # Maybe mirror has compressed it?
4182             if (-f "$l.gz") {
4183                 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
4184                 eval { CPAN::Tarzip->new("$l.gz")->gunzip($aslocal) };
4185                 if ( -f $aslocal) {
4186                     $ThesiteURL = $ro_url;
4187                     return $aslocal;
4188                 }
4189             }
4190             $CPAN::Frontend->mywarn("Could not find '$l'\n");
4191         }
4192         $self->debug("it was not a file URL") if $CPAN::DEBUG;
4193         if ($CPAN::META->has_usable('LWP')) {
4194             $CPAN::Frontend->myprint("Fetching with LWP:
4195   $url
4196 ");
4197             unless ($Ua) {
4198                 CPAN::LWP::UserAgent->config;
4199                 eval { $Ua = CPAN::LWP::UserAgent->new; };
4200                 if ($@) {
4201                     $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
4202                 }
4203             }
4204             my $res = $Ua->mirror($url, $aslocal);
4205             if ($res->is_success) {
4206                 $ThesiteURL = $ro_url;
4207                 my $now = time;
4208                 utime $now, $now, $aslocal; # download time is more
4209                                             # important than upload
4210                                             # time
4211                 return $aslocal;
4212             } elsif ($url !~ /\.gz(?!\n)\Z/) {
4213                 my $gzurl = "$url.gz";
4214                 $CPAN::Frontend->myprint("Fetching with LWP:
4215   $gzurl
4216 ");
4217                 $res = $Ua->mirror($gzurl, "$aslocal.gz");
4218                 if ($res->is_success) {
4219                     if (eval {CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)}) {
4220                         $ThesiteURL = $ro_url;
4221                         return $aslocal;
4222                     }
4223                 }
4224             } else {
4225                 $CPAN::Frontend->myprint(sprintf(
4226                                                  "LWP failed with code[%s] message[%s]\n",
4227                                                  $res->code,
4228                                                  $res->message,
4229                                                 ));
4230                 # Alan Burlison informed me that in firewall environments
4231                 # Net::FTP can still succeed where LWP fails. So we do not
4232                 # skip Net::FTP anymore when LWP is available.
4233             }
4234         } else {
4235             $CPAN::Frontend->mywarn("  LWP not available\n");
4236         }
4237         return if $CPAN::Signal;
4238         if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
4239             # that's the nice and easy way thanks to Graham
4240             $self->debug("recognized ftp") if $CPAN::DEBUG;
4241             my($host,$dir,$getfile) = ($1,$2,$3);
4242             if ($CPAN::META->has_usable('Net::FTP')) {
4243                 $dir =~ s|/+|/|g;
4244                 $CPAN::Frontend->myprint("Fetching with Net::FTP:
4245   $url
4246 ");
4247                 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
4248                              "aslocal[$aslocal]") if $CPAN::DEBUG;
4249                 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
4250                     $ThesiteURL = $ro_url;
4251                     return $aslocal;
4252                 }
4253                 if ($aslocal !~ /\.gz(?!\n)\Z/) {
4254                     my $gz = "$aslocal.gz";
4255                     $CPAN::Frontend->myprint("Fetching with Net::FTP
4256   $url.gz
4257 ");
4258                     if (CPAN::FTP->ftp_get($host,
4259                                            $dir,
4260                                            "$getfile.gz",
4261                                            $gz) &&
4262                         eval{CPAN::Tarzip->new($gz)->gunzip($aslocal)}
4263                     ) {
4264                         $ThesiteURL = $ro_url;
4265                         return $aslocal;
4266                     }
4267                 }
4268                 # next HOSTEASY;
4269             } else {
4270                 CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG;
4271             }
4272         }
4273         if (
4274             UNIVERSAL::can($ro_url,"text")
4275             and
4276             $ro_url->{FROM} eq "USER"
4277            ) {
4278             ##address #17973: default URLs should not try to override
4279             ##user-defined URLs just because LWP is not available
4280             my $ret = $self->hostdlhard([$ro_url],$file,$aslocal,$stats);
4281             return $ret if $ret;
4282         }
4283         return if $CPAN::Signal;
4284     }
4285 }
4286
4287 # package CPAN::FTP;
4288 sub hostdlhard {
4289     my($self,$host_seq,$file,$aslocal,$stats) = @_;
4290
4291     # Came back if Net::FTP couldn't establish connection (or
4292     # failed otherwise) Maybe they are behind a firewall, but they
4293     # gave us a socksified (or other) ftp program...
4294
4295     my($ro_url);
4296     my($devnull) = $CPAN::Config->{devnull} || "";
4297     # < /dev/null ";
4298     my($aslocal_dir) = File::Basename::dirname($aslocal);
4299     File::Path::mkpath($aslocal_dir);
4300   HOSTHARD: for $ro_url (@$host_seq) {
4301         $self->_set_attempt($stats,"dlhard",$ro_url);
4302         my $url = "$ro_url$file";
4303         my($proto,$host,$dir,$getfile);
4304
4305         # Courtesy Mark Conty mark_conty@cargill.com change from
4306         # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
4307         # to
4308         if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
4309             # proto not yet used
4310             ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
4311         } else {
4312             next HOSTHARD; # who said, we could ftp anything except ftp?
4313         }
4314         next HOSTHARD if $proto eq "file"; # file URLs would have had
4315                                            # success above. Likely a bogus URL
4316
4317         $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
4318
4319         # Try the most capable first and leave ncftp* for last as it only
4320         # does FTP.
4321       DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
4322             my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
4323             next unless defined $funkyftp;
4324             next if $funkyftp =~ /^\s*$/;
4325
4326             my($asl_ungz, $asl_gz);
4327             ($asl_ungz = $aslocal) =~ s/\.gz//;
4328                 $asl_gz = "$asl_ungz.gz";
4329
4330             my($src_switch) = "";
4331             my($chdir) = "";
4332             my($stdout_redir) = " > $asl_ungz";
4333             if ($f eq "lynx") {
4334                 $src_switch = " -source";
4335             } elsif ($f eq "ncftp") {
4336                 $src_switch = " -c";
4337             } elsif ($f eq "wget") {
4338                 $src_switch = " -O $asl_ungz";
4339                 $stdout_redir = "";
4340             } elsif ($f eq 'curl') {
4341                 $src_switch = ' -L -f -s -S --netrc-optional';
4342             }
4343
4344             if ($f eq "ncftpget") {
4345                 $chdir = "cd $aslocal_dir && ";
4346                 $stdout_redir = "";
4347             }
4348             $CPAN::Frontend->myprint(
4349                                      qq[
4350 Trying with "$funkyftp$src_switch" to get
4351     $url
4352 ]);
4353             my($system) =
4354                 "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
4355             $self->debug("system[$system]") if $CPAN::DEBUG;
4356             my($wstatus) = system($system);
4357             if ($f eq "lynx") {
4358                 # lynx returns 0 when it fails somewhere
4359                 if (-s $asl_ungz) {
4360                     my $content = do { local *FH;
4361                                        open FH, $asl_ungz or die;
4362                                        local $/;
4363                                        <FH> };
4364                     if ($content =~ /^<.*(<title>[45]|Error [45])/si) {
4365                         $CPAN::Frontend->mywarn(qq{
4366 No success, the file that lynx has downloaded looks like an error message:
4367 $content
4368 });
4369                         $CPAN::Frontend->mysleep(1);
4370                         next DLPRG;
4371                     }
4372                 } else {
4373                     $CPAN::Frontend->myprint(qq{
4374 No success, the file that lynx has downloaded is an empty file.
4375 });
4376                     next DLPRG;
4377                 }
4378             }
4379             if ($wstatus == 0) {
4380                 if (-s $aslocal) {
4381                     # Looks good
4382                 } elsif ($asl_ungz ne $aslocal) {
4383                     # test gzip integrity
4384                     if (eval{CPAN::Tarzip->new($asl_ungz)->gtest}) {
4385                         # e.g. foo.tar is gzipped --> foo.tar.gz
4386                         rename $asl_ungz, $aslocal;
4387                     } else {
4388                         eval{CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz)};
4389                     }
4390                 }
4391                 $ThesiteURL = $ro_url;
4392                 return $aslocal;
4393             } elsif ($url !~ /\.gz(?!\n)\Z/) {
4394                 unlink $asl_ungz if
4395                     -f $asl_ungz && -s _ == 0;
4396                 my $gz = "$aslocal.gz";
4397                 my $gzurl = "$url.gz";
4398                 $CPAN::Frontend->myprint(
4399                                         qq[
4400     Trying with "$funkyftp$src_switch" to get
4401     $url.gz
4402     ]);
4403                 my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
4404                 $self->debug("system[$system]") if $CPAN::DEBUG;
4405                 my($wstatus);
4406                 if (($wstatus = system($system)) == 0
4407                     &&
4408                     -s $asl_gz
4409                 ) {
4410                     # test gzip integrity
4411                     my $ct = eval{CPAN::Tarzip->new($asl_gz)};
4412                     if ($ct && $ct->gtest) {
4413                         $ct->gunzip($aslocal);
4414                     } else {
4415                         # somebody uncompressed file for us?
4416                         rename $asl_ungz, $aslocal;
4417                     }
4418                     $ThesiteURL = $ro_url;
4419                     return $aslocal;
4420                 } else {
4421                     unlink $asl_gz if -f $asl_gz;
4422                 }
4423             } else {
4424                 my $estatus = $wstatus >> 8;
4425                 my $size = -f $aslocal ?
4426                     ", left\n$aslocal with size ".-s _ :
4427                     "\nWarning: expected file [$aslocal] doesn't exist";
4428                 $CPAN::Frontend->myprint(qq{
4429     System call "$system"
4430     returned status $estatus (wstat $wstatus)$size
4431     });
4432             }
4433             return if $CPAN::Signal;
4434         } # transfer programs
4435     } # host
4436 }
4437
4438 # package CPAN::FTP;
4439 sub hostdlhardest {
4440     my($self,$host_seq,$file,$aslocal,$stats) = @_;
4441
4442     return unless @$host_seq;
4443     my($ro_url);
4444     my($aslocal_dir) = File::Basename::dirname($aslocal);
4445     File::Path::mkpath($aslocal_dir);
4446     my $ftpbin = $CPAN::Config->{ftp};
4447     unless ($ftpbin && length $ftpbin && MM->maybe_command($ftpbin)) {
4448         $CPAN::Frontend->myprint("No external ftp command available\n\n");
4449         return;
4450     }
4451     $CPAN::Frontend->mywarn(qq{
4452 As a last ressort we now switch to the external ftp command '$ftpbin'
4453 to get '$aslocal'.
4454
4455 Doing so often leads to problems that are hard to diagnose.
4456
4457 If you're victim of such problems, please consider unsetting the ftp
4458 config variable with
4459
4460     o conf ftp ""
4461     o conf commit
4462
4463 });
4464     $CPAN::Frontend->mysleep(2);
4465   HOSTHARDEST: for $ro_url (@$host_seq) {
4466         $self->_set_attempt($stats,"dlhardest",$ro_url);
4467         my $url = "$ro_url$file";
4468         $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
4469         unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
4470             next;
4471         }
4472         my($host,$dir,$getfile) = ($1,$2,$3);
4473         my $timestamp = 0;
4474         my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
4475             $ctime,$blksize,$blocks) = stat($aslocal);
4476         $timestamp = $mtime ||= 0;
4477         my($netrc) = CPAN::FTP::netrc->new;
4478         my($netrcfile) = $netrc->netrc;
4479         my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
4480         my $targetfile = File::Basename::basename($aslocal);
4481         my(@dialog);
4482         push(
4483              @dialog,
4484              "lcd $aslocal_dir",
4485              "cd /",
4486              map("cd $_", split /\//, $dir), # RFC 1738
4487              "bin",
4488              "get $getfile $targetfile",
4489              "quit"
4490         );
4491         if (! $netrcfile) {
4492             CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
4493         } elsif ($netrc->hasdefault || $netrc->contains($host)) {
4494             CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
4495                                 $netrc->hasdefault,
4496                                 $netrc->contains($host))) if $CPAN::DEBUG;
4497             if ($netrc->protected) {
4498                 my $dialog = join "", map { "    $_\n" } @dialog;
4499                 my $netrc_explain;
4500                 if ($netrc->contains($host)) {
4501                     $netrc_explain = "Relying that your .netrc entry for '$host' ".
4502                         "manages the login";
4503                 } else {
4504                     $netrc_explain = "Relying that your default .netrc entry ".
4505                         "manages the login";
4506                 }
4507                 $CPAN::Frontend->myprint(qq{
4508   Trying with external ftp to get
4509     $url
4510   $netrc_explain
4511   Going to send the dialog
4512 $dialog
4513 }
4514                 );
4515                 $self->talk_ftp("$ftpbin$verbose $host",
4516                                 @dialog);
4517                 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4518                     $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
4519                 $mtime ||= 0;
4520                 if ($mtime > $timestamp) {
4521                     $CPAN::Frontend->myprint("GOT $aslocal\n");
4522                     $ThesiteURL = $ro_url;
4523                     return $aslocal;
4524                 } else {
4525                     $CPAN::Frontend->myprint("Hmm... Still failed!\n");
4526                 }
4527                     return if $CPAN::Signal;
4528             } else {
4529                 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
4530                                         qq{correctly protected.\n});
4531             }
4532         } else {
4533             $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
4534   nor does it have a default entry\n");
4535         }
4536
4537         # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
4538         # then and login manually to host, using e-mail as
4539         # password.
4540         $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
4541         unshift(
4542                 @dialog,
4543                 "open $host",
4544                 "user anonymous $Config::Config{'cf_email'}"
4545         );
4546         my $dialog = join "", map { "    $_\n" } @dialog;
4547         $CPAN::Frontend->myprint(qq{
4548   Trying with external ftp to get
4549     $url
4550   Going to send the dialog
4551 $dialog
4552 }
4553         );
4554         $self->talk_ftp("$ftpbin$verbose -n", @dialog);
4555         ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4556             $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
4557         $mtime ||= 0;
4558         if ($mtime > $timestamp) {
4559             $CPAN::Frontend->myprint("GOT $aslocal\n");
4560             $ThesiteURL = $ro_url;
4561             return $aslocal;
4562         } else {
4563             $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
4564         }
4565         return if $CPAN::Signal;
4566         $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
4567         $CPAN::Frontend->mysleep(2);
4568     } # host
4569 }
4570
4571 # package CPAN::FTP;
4572 sub talk_ftp {
4573     my($self,$command,@dialog) = @_;
4574     my $fh = FileHandle->new;
4575     $fh->open("|$command") or die "Couldn't open ftp: $!";
4576     foreach (@dialog) { $fh->print("$_\n") }
4577     $fh->close; # Wait for process to complete
4578     my $wstatus = $?;
4579     my $estatus = $wstatus >> 8;
4580     $CPAN::Frontend->myprint(qq{
4581 Subprocess "|$command"
4582   returned status $estatus (wstat $wstatus)
4583 }) if $wstatus;
4584 }
4585
4586 # find2perl needs modularization, too, all the following is stolen
4587 # from there
4588 # CPAN::FTP::ls
4589 sub ls {
4590     my($self,$name) = @_;
4591     my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
4592      $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
4593
4594     my($perms,%user,%group);
4595     my $pname = $name;
4596
4597     if ($blocks) {
4598         $blocks = int(($blocks + 1) / 2);
4599     }
4600     else {
4601         $blocks = int(($sizemm + 1023) / 1024);
4602     }
4603
4604     if    (-f _) { $perms = '-'; }
4605     elsif (-d _) { $perms = 'd'; }
4606     elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
4607     elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
4608     elsif (-p _) { $perms = 'p'; }
4609     elsif (-S _) { $perms = 's'; }
4610     else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
4611
4612     my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
4613     my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
4614     my $tmpmode = $mode;
4615     my $tmp = $rwx[$tmpmode & 7];
4616     $tmpmode >>= 3;
4617     $tmp = $rwx[$tmpmode & 7] . $tmp;
4618     $tmpmode >>= 3;
4619     $tmp = $rwx[$tmpmode & 7] . $tmp;
4620     substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
4621     substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
4622     substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
4623     $perms .= $tmp;
4624
4625     my $user = $user{$uid} || $uid;   # too lazy to implement lookup
4626     my $group = $group{$gid} || $gid;
4627
4628     my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
4629     my($timeyear);
4630     my($moname) = $moname[$mon];
4631     if (-M _ > 365.25 / 2) {
4632         $timeyear = $year + 1900;
4633     }
4634     else {
4635         $timeyear = sprintf("%02d:%02d", $hour, $min);
4636     }
4637
4638     sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
4639              $ino,
4640                   $blocks,
4641                        $perms,
4642                              $nlink,
4643                                  $user,
4644                                       $group,
4645                                            $sizemm,
4646                                                $moname,
4647                                                   $mday,
4648                                                       $timeyear,
4649                                                           $pname;
4650 }
4651
4652 package CPAN::FTP::netrc;
4653 use strict;
4654
4655 # package CPAN::FTP::netrc;
4656 sub new {
4657     my($class) = @_;
4658     my $home = CPAN::HandleConfig::home;
4659     my $file = File::Spec->catfile($home,".netrc");
4660
4661     my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4662        $atime,$mtime,$ctime,$blksize,$blocks)
4663         = stat($file);
4664     $mode ||= 0;
4665     my $protected = 0;
4666
4667     my($fh,@machines,$hasdefault);
4668     $hasdefault = 0;
4669     $fh = FileHandle->new or die "Could not create a filehandle";
4670
4671     if($fh->open($file)) {
4672         $protected = ($mode & 077) == 0;
4673         local($/) = "";
4674       NETRC: while (<$fh>) {
4675             my(@tokens) = split " ", $_;
4676           TOKEN: while (@tokens) {
4677                 my($t) = shift @tokens;
4678                 if ($t eq "default") {
4679                     $hasdefault++;
4680                     last NETRC;
4681                 }
4682                 last TOKEN if $t eq "macdef";
4683                 if ($t eq "machine") {
4684                     push @machines, shift @tokens;
4685                 }
4686             }
4687         }
4688     } else {
4689         $file = $hasdefault = $protected = "";
4690     }
4691
4692     bless {
4693         'mach' => [@machines],
4694         'netrc' => $file,
4695         'hasdefault' => $hasdefault,
4696         'protected' => $protected,
4697     }, $class;
4698 }
4699
4700 # CPAN::FTP::netrc::hasdefault;
4701 sub hasdefault { shift->{'hasdefault'} }
4702 sub netrc      { shift->{'netrc'}      }
4703 sub protected  { shift->{'protected'}  }
4704 sub contains {
4705     my($self,$mach) = @_;
4706     for ( @{$self->{'mach'}} ) {
4707         return 1 if $_ eq $mach;
4708     }
4709     return 0;
4710 }
4711
4712 package CPAN::Complete;
4713 use strict;
4714
4715 sub gnu_cpl {
4716     my($text, $line, $start, $end) = @_;
4717     my(@perlret) = cpl($text, $line, $start);
4718     # find longest common match. Can anybody show me how to peruse
4719     # T::R::Gnu to have this done automatically? Seems expensive.
4720     return () unless @perlret;
4721     my($newtext) = $text;
4722     for (my $i = length($text)+1;;$i++) {
4723         last unless length($perlret[0]) && length($perlret[0]) >= $i;
4724         my $try = substr($perlret[0],0,$i);
4725         my @tries = grep {substr($_,0,$i) eq $try} @perlret;
4726         # warn "try[$try]tries[@tries]";
4727         if (@tries == @perlret) {
4728             $newtext = $try;
4729         } else {
4730             last;
4731         }
4732     }
4733     ($newtext,@perlret);
4734 }
4735
4736 #-> sub CPAN::Complete::cpl ;
4737 sub cpl {
4738     my($word,$line,$pos) = @_;
4739     $word ||= "";
4740     $line ||= "";
4741     $pos ||= 0;
4742     CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4743     $line =~ s/^\s*//;
4744     if ($line =~ s/^((?:notest|f?force)\s*)//) {
4745         $pos -= length($1);
4746     }
4747     my @return;
4748     if ($pos == 0 || $line =~ /^(?:h(?:elp)?|\?)\s/) {
4749         @return = grep /^\Q$word\E/, @CPAN::Complete::COMMANDS;
4750     } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
4751         @return = ();
4752     } elsif ($line =~ /^(a|ls)\s/) {
4753         @return = cplx('CPAN::Author',uc($word));
4754     } elsif ($line =~ /^b\s/) {
4755         CPAN::Shell->local_bundles;
4756         @return = cplx('CPAN::Bundle',$word);
4757     } elsif ($line =~ /^d\s/) {
4758         @return = cplx('CPAN::Distribution',$word);
4759     } elsif ($line =~ m/^(
4760                           [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
4761                          )\s/x ) {
4762         if ($word =~ /^Bundle::/) {
4763             CPAN::Shell->local_bundles;
4764         }
4765         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
4766     } elsif ($line =~ /^i\s/) {
4767         @return = cpl_any($word);
4768     } elsif ($line =~ /^reload\s/) {
4769         @return = cpl_reload($word,$line,$pos);
4770     } elsif ($line =~ /^o\s/) {
4771         @return = cpl_option($word,$line,$pos);
4772     } elsif ($line =~ m/^\S+\s/ ) {
4773         # fallback for future commands and what we have forgotten above
4774         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
4775     } else {
4776         @return = ();
4777     }
4778     return @return;
4779 }
4780
4781 #-> sub CPAN::Complete::cplx ;
4782 sub cplx {
4783     my($class, $word) = @_;
4784     if (CPAN::_sqlite_running) {
4785         $CPAN::SQLite->search($class, "^\Q$word\E");
4786     }
4787     sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
4788 }
4789
4790 #-> sub CPAN::Complete::cpl_any ;
4791 sub cpl_any {
4792     my($word) = shift;
4793     return (
4794             cplx('CPAN::Author',$word),
4795             cplx('CPAN::Bundle',$word),
4796             cplx('CPAN::Distribution',$word),
4797             cplx('CPAN::Module',$word),
4798            );
4799 }
4800
4801 #-> sub CPAN::Complete::cpl_reload ;
4802 sub cpl_reload {
4803     my($word,$line,$pos) = @_;
4804     $word ||= "";
4805     my(@words) = split " ", $line;
4806     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4807     my(@ok) = qw(cpan index);
4808     return @ok if @words == 1;
4809     return grep /^\Q$word\E/, @ok if @words == 2 && $word;
4810 }
4811
4812 #-> sub CPAN::Complete::cpl_option ;
4813 sub cpl_option {
4814     my($word,$line,$pos) = @_;
4815     $word ||= "";
4816     my(@words) = split " ", $line;
4817     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4818     my(@ok) = qw(conf debug);
4819     return @ok if @words == 1;
4820     return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
4821     if (0) {
4822     } elsif ($words[1] eq 'index') {
4823         return ();
4824     } elsif ($words[1] eq 'conf') {
4825         return CPAN::HandleConfig::cpl(@_);
4826     } elsif ($words[1] eq 'debug') {
4827         return sort grep /^\Q$word\E/i,
4828             sort keys %CPAN::DEBUG, 'all';
4829     }
4830 }
4831
4832 package CPAN::Index;
4833 use strict;
4834
4835 #-> sub CPAN::Index::force_reload ;
4836 sub force_reload {
4837     my($class) = @_;
4838     $CPAN::Index::LAST_TIME = 0;
4839     $class->reload(1);
4840 }
4841
4842 #-> sub CPAN::Index::reload ;
4843 sub reload {
4844     my($self,$force) = @_;
4845     my $time = time;
4846
4847     # XXX check if a newer one is available. (We currently read it
4848     # from time to time)
4849     for ($CPAN::Config->{index_expire}) {
4850         $_ = 0.001 unless $_ && $_ > 0.001;
4851     }
4852     unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
4853         # debug here when CPAN doesn't seem to read the Metadata
4854         require Carp;
4855         Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
4856     }
4857     unless ($CPAN::META->{PROTOCOL}) {
4858         $self->read_metadata_cache;
4859         $CPAN::META->{PROTOCOL} ||= "1.0";
4860     }
4861     if ( $CPAN::META->{PROTOCOL} < PROTOCOL  ) {
4862         # warn "Setting last_time to 0";
4863         $LAST_TIME = 0; # No warning necessary
4864     }
4865     if ($LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
4866         and ! $force) {
4867         # called too often
4868         # CPAN->debug("LAST_TIME[$LAST_TIME]index_expire[$CPAN::Config->{index_expire}]time[$time]");
4869     } elsif (0) {
4870         # IFF we are developing, it helps to wipe out the memory
4871         # between reloads, otherwise it is not what a user expects.
4872         undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
4873         $CPAN::META = CPAN->new;
4874     } else {
4875         my($debug,$t2);
4876         local $LAST_TIME = $time;
4877         local $CPAN::META->{PROTOCOL} = PROTOCOL;
4878
4879         my $needshort = $^O eq "dos";
4880
4881         $self->rd_authindex($self
4882                           ->reload_x(
4883                                      "authors/01mailrc.txt.gz",
4884                                      $needshort ?
4885                                      File::Spec->catfile('authors', '01mailrc.gz') :
4886                                      File::Spec->catfile('authors', '01mailrc.txt.gz'),
4887                                      $force));
4888         $t2 = time;
4889         $debug = "timing reading 01[".($t2 - $time)."]";
4890         $time = $t2;
4891         return if $CPAN::Signal; # this is sometimes lengthy
4892         $self->rd_modpacks($self
4893                          ->reload_x(
4894                                     "modules/02packages.details.txt.gz",
4895                                     $needshort ?
4896                                     File::Spec->catfile('modules', '02packag.gz') :
4897                                     File::Spec->catfile('modules', '02packages.details.txt.gz'),
4898                                     $force));
4899         $t2 = time;
4900         $debug .= "02[".($t2 - $time)."]";
4901         $time = $t2;
4902         return if $CPAN::Signal; # this is sometimes lengthy
4903         $self->rd_modlist($self
4904                         ->reload_x(
4905                                    "modules/03modlist.data.gz",
4906                                    $needshort ?
4907                                    File::Spec->catfile('modules', '03mlist.gz') :
4908                                    File::Spec->catfile('modules', '03modlist.data.gz'),
4909                                    $force));
4910         $self->write_metadata_cache;
4911         $t2 = time;
4912         $debug .= "03[".($t2 - $time)."]";
4913         $time = $t2;
4914         CPAN->debug($debug) if $CPAN::DEBUG;
4915     }
4916     if ($CPAN::Config->{build_dir_reuse}) {
4917         $self->reanimate_build_dir;
4918     }
4919     if (CPAN::_sqlite_running) {
4920         $CPAN::SQLite->reload(time => $time, force => $force)
4921             if not $LAST_TIME;
4922     }
4923     $LAST_TIME = $time;
4924     $CPAN::META->{PROTOCOL} = PROTOCOL;
4925 }
4926
4927 #-> sub CPAN::Index::reanimate_build_dir ;
4928 sub reanimate_build_dir {
4929     my($self) = @_;
4930     unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module}||"YAML")) {
4931         return;
4932     }
4933     return if $HAVE_REANIMATED++;
4934     my $d = $CPAN::Config->{build_dir};
4935     my $dh = DirHandle->new;
4936     opendir $dh, $d or return; # does not exist
4937     my $dirent;
4938     my $i = 0;
4939     my $painted = 0;
4940     my $restored = 0;
4941     $CPAN::Frontend->myprint("Going to read $CPAN::Config->{build_dir}/\n");
4942     my @candidates = map { $_->[0] }
4943         sort { $b->[1] <=> $a->[1] }
4944             map { [ $_, -M File::Spec->catfile($d,$_) ] }
4945                 grep {/\.yml$/} readdir $dh;
4946   DISTRO: for $i (0..$#candidates) {
4947         my $dirent = $candidates[$i];
4948         my $y = eval {CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))};
4949         if ($@) {
4950             warn "Error while parsing file '$dirent'; error: '$@'";
4951             next DISTRO;
4952         }
4953         my $c = $y->[0];
4954         if ($c && CPAN->_perl_fingerprint($c->{perl})) {
4955             my $key = $c->{distribution}{ID};
4956             for my $k (keys %{$c->{distribution}}) {
4957                 if ($c->{distribution}{$k}
4958                     && ref $c->{distribution}{$k}
4959                     && UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) {
4960                     $c->{distribution}{$k}{COMMANDID} = $i - @candidates;
4961                 }
4962             }
4963
4964             #we tried to restore only if element already
4965             #exists; but then we do not work with metadata
4966             #turned off.
4967             my $do
4968                 = $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key}
4969                     = $c->{distribution};
4970             for my $skipper (qw(
4971                                 badtestcnt
4972                                 configure_requires_later
4973                                 configure_requires_later_for
4974                                 force_update
4975                                 later
4976                                 later_for
4977                                 notest
4978                                 should_report
4979                                 sponsored_mods
4980                                )) {
4981                 delete $do->{$skipper};
4982             }
4983             # $DB::single = 1;
4984             if ($do->{make_test}
4985                 && $do->{build_dir}
4986                 && !(UNIVERSAL::can($do->{make_test},"failed") ?
4987                      $do->{make_test}->failed :
4988                      $do->{make_test} =~ /^YES/
4989                     )
4990                 && (
4991                     !$do->{install}
4992                     ||
4993                     $do->{install}->failed
4994                    )
4995                ) {
4996                 $CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME});
4997             }
4998             $restored++;
4999         }
5000         $i++;
5001         while (($painted/76) < ($i/@candidates)) {
5002             $CPAN::Frontend->myprint(".");
5003             $painted++;
5004         }
5005     }
5006     $CPAN::Frontend->myprint(sprintf(
5007                                      "DONE\nFound %s old build%s, restored the state of %s\n",
5008                                      @candidates ? sprintf("%d",scalar @candidates) : "no",
5009                                      @candidates==1 ? "" : "s",
5010                                      $restored || "none",
5011                                     ));
5012 }
5013
5014
5015 #-> sub CPAN::Index::reload_x ;
5016 sub reload_x {
5017     my($cl,$wanted,$localname,$force) = @_;
5018     $force |= 2; # means we're dealing with an index here
5019     CPAN::HandleConfig->load; # we should guarantee loading wherever
5020                               # we rely on Config XXX
5021     $localname ||= $wanted;
5022     my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
5023                                          $localname);
5024     if (
5025         -f $abs_wanted &&
5026         -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
5027         !($force & 1)
5028        ) {
5029         my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
5030         $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
5031                    qq{day$s. I\'ll use that.});
5032         return $abs_wanted;
5033     } else {
5034         $force |= 1; # means we're quite serious about it.
5035     }
5036     return CPAN::FTP->localize($wanted,$abs_wanted,$force);
5037 }
5038
5039 #-> sub CPAN::Index::rd_authindex ;
5040 sub rd_authindex {
5041     my($cl, $index_target) = @_;
5042     return unless defined $index_target;
5043     return if CPAN::_sqlite_running;
5044     my @lines;
5045     $CPAN::Frontend->myprint("Going to read $index_target\n");
5046     local(*FH);
5047     tie *FH, 'CPAN::Tarzip', $index_target;
5048     local($/) = "\n";
5049     local($_);
5050     push @lines, split /\012/ while <FH>;
5051     my $i = 0;
5052     my $painted = 0;
5053     foreach (@lines) {
5054         my($userid,$fullname,$email) =
5055             m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/;
5056         $fullname ||= $email;
5057         if ($userid && $fullname && $email) {
5058             my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
5059             $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
5060         } else {
5061             CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG;
5062         }
5063         $i++;
5064         while (($painted/76) < ($i/@lines)) {
5065             $CPAN::Frontend->myprint(".");
5066             $painted++;
5067         }
5068         return if $CPAN::Signal;
5069     }
5070     $CPAN::Frontend->myprint("DONE\n");
5071 }
5072
5073 sub userid {
5074   my($self,$dist) = @_;
5075   $dist = $self->{'id'} unless defined $dist;
5076   my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
5077   $ret;
5078 }
5079
5080 #-> sub CPAN::Index::rd_modpacks ;
5081 sub rd_modpacks {
5082     my($self, $index_target) = @_;
5083     return unless defined $index_target;
5084     return if CPAN::_sqlite_running;
5085     $CPAN::Frontend->myprint("Going to read $index_target\n");
5086     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
5087     local $_;
5088     CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
5089     my $slurp = "";
5090     my $chunk;
5091     while (my $bytes = $fh->READ(\$chunk,8192)) {
5092         $slurp.=$chunk;
5093     }
5094     my @lines = split /\012/, $slurp;
5095     CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
5096     undef $fh;
5097     # read header
5098     my($line_count,$last_updated);
5099     while (@lines) {
5100         my $shift = shift(@lines);
5101         last if $shift =~ /^\s*$/;
5102         $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
5103         $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
5104     }
5105     CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
5106     if (not defined $line_count) {
5107
5108         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
5109 Please check the validity of the index file by comparing it to more
5110 than one CPAN mirror. I'll continue but problems seem likely to
5111 happen.\a
5112 });
5113
5114         $CPAN::Frontend->mysleep(5);
5115     } elsif ($line_count != scalar @lines) {
5116
5117         $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
5118 contains a Line-Count header of %d but I see %d lines there. Please
5119 check the validity of the index file by comparing it to more than one
5120 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
5121 $index_target, $line_count, scalar(@lines));
5122
5123     }
5124     if (not defined $last_updated) {
5125
5126         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
5127 Please check the validity of the index file by comparing it to more
5128 than one CPAN mirror. I'll continue but problems seem likely to
5129 happen.\a
5130 });
5131
5132         $CPAN::Frontend->mysleep(5);
5133     } else {
5134
5135         $CPAN::Frontend
5136             ->myprint(sprintf qq{  Database was generated on %s\n},
5137                       $last_updated);
5138         $DATE_OF_02 = $last_updated;
5139
5140         my $age = time;
5141         if ($CPAN::META->has_inst('HTTP::Date')) {
5142             require HTTP::Date;
5143             $age -= HTTP::Date::str2time($last_updated);
5144         } else {
5145             $CPAN::Frontend->mywarn("  HTTP::Date not available\n");
5146             require Time::Local;
5147             my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
5148             $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
5149             $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
5150         }
5151         $age /= 3600*24;
5152         if ($age > 30) {
5153
5154             $CPAN::Frontend
5155                 ->mywarn(sprintf
5156                          qq{Warning: This index file is %d days old.
5157   Please check the host you chose as your CPAN mirror for staleness.
5158   I'll continue but problems seem likely to happen.\a\n},
5159                          $age);
5160
5161         } elsif ($age < -1) {
5162
5163             $CPAN::Frontend
5164                 ->mywarn(sprintf
5165                          qq{Warning: Your system date is %d days behind this index file!
5166   System time:          %s
5167   Timestamp index file: %s
5168   Please fix your system time, problems with the make command expected.\n},
5169                          -$age,
5170                          scalar gmtime,
5171                          $DATE_OF_02,
5172                         );
5173
5174         }
5175     }
5176
5177
5178     # A necessity since we have metadata_cache: delete what isn't
5179     # there anymore
5180     my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
5181     CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
5182     my(%exists);
5183     my $i = 0;
5184     my $painted = 0;
5185     foreach (@lines) {
5186         # before 1.56 we split into 3 and discarded the rest. From
5187         # 1.57 we assign remaining text to $comment thus allowing to
5188         # influence isa_perl
5189         my($mod,$version,$dist,$comment) = split " ", $_, 4;
5190         my($bundle,$id,$userid);
5191
5192         if ($mod eq 'CPAN' &&
5193             ! (
5194             CPAN::Queue->exists('Bundle::CPAN') ||
5195             CPAN::Queue->exists('CPAN')
5196             )
5197         ) {
5198             local($^W)= 0;
5199             if ($version > $CPAN::VERSION) {
5200                 $CPAN::Frontend->mywarn(qq{
5201   New CPAN.pm version (v$version) available.
5202   [Currently running version is v$CPAN::VERSION]
5203   You might want to try
5204     install CPAN
5205     reload cpan
5206   to both upgrade CPAN.pm and run the new version without leaving
5207   the current session.
5208
5209 }); #});
5210                 $CPAN::Frontend->mysleep(2);
5211                 $CPAN::Frontend->myprint(qq{\n});
5212             }
5213             last if $CPAN::Signal;
5214         } elsif ($mod =~ /^Bundle::(.*)/) {
5215             $bundle = $1;
5216         }
5217
5218         if ($bundle) {
5219             $id =  $CPAN::META->instance('CPAN::Bundle',$mod);
5220             # Let's make it a module too, because bundles have so much
5221             # in common with modules.
5222
5223             # Changed in 1.57_63: seems like memory bloat now without
5224             # any value, so commented out
5225
5226             # $CPAN::META->instance('CPAN::Module',$mod);
5227
5228         } else {
5229
5230             # instantiate a module object
5231             $id = $CPAN::META->instance('CPAN::Module',$mod);
5232
5233         }
5234
5235         # Although CPAN prohibits same name with different version the
5236         # indexer may have changed the version for the same distro
5237         # since the last time ("Force Reindexing" feature)
5238         if ($id->cpan_file ne $dist
5239             ||
5240             $id->cpan_version ne $version
5241            ) {
5242             $userid = $id->userid || $self->userid($dist);
5243             $id->set(
5244                      'CPAN_USERID' => $userid,
5245                      'CPAN_VERSION' => $version,
5246                      'CPAN_FILE' => $dist,
5247                     );
5248         }
5249
5250         # instantiate a distribution object
5251         if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
5252         # we do not need CONTAINSMODS unless we do something with
5253         # this dist, so we better produce it on demand.
5254
5255         ## my $obj = $CPAN::META->instance(
5256         ##                                 'CPAN::Distribution' => $dist
5257         ##                                );
5258         ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
5259         } else {
5260             $CPAN::META->instance(
5261                                   'CPAN::Distribution' => $dist
5262                                  )->set(
5263                                         'CPAN_USERID' => $userid,
5264                                         'CPAN_COMMENT' => $comment,
5265                                        );
5266         }
5267         if ($secondtime) {
5268             for my $name ($mod,$dist) {
5269                 # $self->debug("exists name[$name]") if $CPAN::DEBUG;
5270                 $exists{$name} = undef;
5271             }
5272         }
5273         $i++;
5274         while (($painted/76) < ($i/@lines)) {
5275             $CPAN::Frontend->myprint(".");
5276             $painted++;
5277         }
5278         return if $CPAN::Signal;
5279     }
5280     $CPAN::Frontend->myprint("DONE\n");
5281     if ($secondtime) {
5282         for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
5283             for my $o ($CPAN::META->all_objects($class)) {
5284                 next if exists $exists{$o->{ID}};
5285                 $CPAN::META->delete($class,$o->{ID});
5286                 # CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
5287                 #     if $CPAN::DEBUG;
5288             }
5289         }
5290     }
5291 }
5292
5293 #-> sub CPAN::Index::rd_modlist ;
5294 sub rd_modlist {
5295     my($cl,$index_target) = @_;
5296     return unless defined $index_target;
5297     return if CPAN::_sqlite_running;
5298     $CPAN::Frontend->myprint("Going to read $index_target\n");
5299     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
5300     local $_;
5301     my $slurp = "";
5302     my $chunk;
5303     while (my $bytes = $fh->READ(\$chunk,8192)) {
5304         $slurp.=$chunk;
5305     }
5306     my @eval2 = split /\012/, $slurp;
5307
5308     while (@eval2) {
5309         my $shift = shift(@eval2);
5310         if ($shift =~ /^Date:\s+(.*)/) {
5311             if ($DATE_OF_03 eq $1) {
5312                 $CPAN::Frontend->myprint("Unchanged.\n");
5313                 return;
5314             }
5315             ($DATE_OF_03) = $1;
5316         }
5317         last if $shift =~ /^\s*$/;
5318     }
5319     push @eval2, q{CPAN::Modulelist->data;};
5320     local($^W) = 0;
5321     my($comp) = Safe->new("CPAN::Safe1");
5322     my($eval2) = join("\n", @eval2);
5323     CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG;
5324     my $ret = $comp->reval($eval2);
5325     Carp::confess($@) if $@;
5326     return if $CPAN::Signal;
5327     my $i = 0;
5328     my $until = keys(%$ret);
5329     my $painted = 0;
5330     CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
5331     for (keys %$ret) {
5332         my $obj = $CPAN::META->instance("CPAN::Module",$_);
5333         delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
5334         $obj->set(%{$ret->{$_}});
5335         $i++;
5336         while (($painted/76) < ($i/$until)) {
5337             $CPAN::Frontend->myprint(".");
5338             $painted++;
5339         }
5340         return if $CPAN::Signal;
5341     }
5342     $CPAN::Frontend->myprint("DONE\n");
5343 }
5344
5345 #-> sub CPAN::Index::write_metadata_cache ;
5346 sub write_metadata_cache {
5347     my($self) = @_;
5348     return unless $CPAN::Config->{'cache_metadata'};
5349     return if CPAN::_sqlite_running;
5350     return unless $CPAN::META->has_usable("Storable");
5351     my $cache;
5352     foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
5353                       CPAN::Distribution)) {
5354         $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
5355     }
5356     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
5357     $cache->{last_time} = $LAST_TIME;
5358     $cache->{DATE_OF_02} = $DATE_OF_02;
5359     $cache->{PROTOCOL} = PROTOCOL;
5360     $CPAN::Frontend->myprint("Going to write $metadata_file\n");
5361     eval { Storable::nstore($cache, $metadata_file) };
5362     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
5363 }
5364
5365 #-> sub CPAN::Index::read_metadata_cache ;
5366 sub read_metadata_cache {
5367     my($self) = @_;
5368     return unless $CPAN::Config->{'cache_metadata'};
5369     return if CPAN::_sqlite_running;
5370     return unless $CPAN::META->has_usable("Storable");
5371     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
5372     return unless -r $metadata_file and -f $metadata_file;
5373     $CPAN::Frontend->myprint("Going to read $metadata_file\n");
5374     my $cache;
5375     eval { $cache = Storable::retrieve($metadata_file) };
5376     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
5377     if (!$cache || !UNIVERSAL::isa($cache, 'HASH')) {
5378         $LAST_TIME = 0;
5379         return;
5380     }
5381     if (exists $cache->{PROTOCOL}) {
5382         if (PROTOCOL > $cache->{PROTOCOL}) {
5383             $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
5384                                             "with protocol v%s, requiring v%s\n",
5385                                             $cache->{PROTOCOL},
5386                                             PROTOCOL)
5387                                    );
5388             return;
5389         }
5390     } else {
5391         $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
5392                                 "with protocol v1.0\n");
5393         return;
5394     }
5395     my $clcnt = 0;
5396     my $idcnt = 0;
5397     while(my($class,$v) = each %$cache) {
5398         next unless $class =~ /^CPAN::/;
5399         $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
5400         while (my($id,$ro) = each %$v) {
5401             $CPAN::META->{readwrite}{$class}{$id} ||=
5402                 $class->new(ID=>$id, RO=>$ro);
5403             $idcnt++;
5404         }
5405         $clcnt++;
5406     }
5407     unless ($clcnt) { # sanity check
5408         $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
5409         return;
5410     }
5411     if ($idcnt < 1000) {
5412         $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
5413                                  "in $metadata_file\n");
5414         return;
5415     }
5416     $CPAN::META->{PROTOCOL} ||=
5417         $cache->{PROTOCOL}; # reading does not up or downgrade, but it
5418                             # does initialize to some protocol
5419     $LAST_TIME = $cache->{last_time};
5420     $DATE_OF_02 = $cache->{DATE_OF_02};
5421     $CPAN::Frontend->myprint("  Database was generated on $DATE_OF_02\n")
5422         if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
5423     return;
5424 }
5425
5426 package CPAN::InfoObj;
5427 use strict;
5428
5429 sub ro {
5430     my $self = shift;
5431     exists $self->{RO} and return $self->{RO};
5432 }
5433
5434 #-> sub CPAN::InfoObj::cpan_userid
5435 sub cpan_userid {
5436     my $self = shift;
5437     my $ro = $self->ro;
5438     if ($ro) {
5439         return $ro->{CPAN_USERID} || "N/A";
5440     } else {
5441         $self->debug("ID[$self->{ID}]");
5442         # N/A for bundles found locally
5443         return "N/A";
5444     }
5445 }
5446
5447 sub id { shift->{ID}; }
5448
5449 #-> sub CPAN::InfoObj::new ;
5450 sub new {
5451     my $this = bless {}, shift;
5452     %$this = @_;
5453     $this
5454 }
5455
5456 # The set method may only be used by code that reads index data or
5457 # otherwise "objective" data from the outside world. All session
5458 # related material may do anything else with instance variables but
5459 # must not touch the hash under the RO attribute. The reason is that
5460 # the RO hash gets written to Metadata file and is thus persistent.
5461
5462 #-> sub CPAN::InfoObj::safe_chdir ;
5463 sub safe_chdir {
5464   my($self,$todir) = @_;
5465   # we die if we cannot chdir and we are debuggable
5466   Carp::confess("safe_chdir called without todir argument")
5467         unless defined $todir and length $todir;
5468   if (chdir $todir) {
5469     $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
5470         if $CPAN::DEBUG;
5471   } else {
5472     if (-e $todir) {
5473         unless (-x $todir) {
5474             unless (chmod 0755, $todir) {
5475                 my $cwd = CPAN::anycwd();
5476                 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
5477                                         "permission to change the permission; cannot ".
5478                                         "chdir to '$todir'\n");
5479                 $CPAN::Frontend->mysleep(5);
5480                 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
5481                                        qq{to todir[$todir]: $!});
5482             }
5483         }
5484     } else {
5485         $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n");
5486     }
5487     if (chdir $todir) {
5488       $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
5489           if $CPAN::DEBUG;
5490     } else {
5491       my $cwd = CPAN::anycwd();
5492       $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
5493                              qq{to todir[$todir] (a chmod has been issued): $!});
5494     }
5495   }
5496 }
5497
5498 #-> sub CPAN::InfoObj::set ;
5499 sub set {
5500     my($self,%att) = @_;
5501     my $class = ref $self;
5502
5503     # This must be ||=, not ||, because only if we write an empty
5504     # reference, only then the set method will write into the readonly
5505     # area. But for Distributions that spring into existence, maybe
5506     # because of a typo, we do not like it that they are written into
5507     # the readonly area and made permanent (at least for a while) and
5508     # that is why we do not "allow" other places to call ->set.
5509     unless ($self->id) {
5510         CPAN->debug("Bug? Empty ID, rejecting");
5511         return;
5512     }
5513     my $ro = $self->{RO} =
5514         $CPAN::META->{readonly}{$class}{$self->id} ||= {};
5515
5516     while (my($k,$v) = each %att) {
5517         $ro->{$k} = $v;
5518     }
5519 }
5520
5521 #-> sub CPAN::InfoObj::as_glimpse ;
5522 sub as_glimpse {
5523     my($self) = @_;
5524     my(@m);
5525     my $class = ref($self);
5526     $class =~ s/^CPAN:://;
5527     my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID};
5528     push @m, sprintf "%-15s %s\n", $class, $id;
5529     join "", @m;
5530 }
5531
5532 #-> sub CPAN::InfoObj::as_string ;
5533 sub as_string {
5534     my($self) = @_;
5535     my(@m);
5536     my $class = ref($self);
5537     $class =~ s/^CPAN:://;
5538     push @m, $class, " id = $self->{ID}\n";
5539     my $ro;
5540     unless ($ro = $self->ro) {
5541         if (substr($self->{ID},-1,1) eq ".") { # directory
5542             $ro = +{};
5543         } else {
5544             $CPAN::Frontend->mywarn("Unknown object $self->{ID}\n");
5545             $CPAN::Frontend->mysleep(5);
5546             return;
5547         }
5548     }
5549     for (sort keys %$ro) {
5550         # next if m/^(ID|RO)$/;
5551         my $extra = "";
5552         if ($_ eq "CPAN_USERID") {
5553             $extra .= " (";
5554             $extra .= $self->fullname;
5555             my $email; # old perls!
5556             if ($email = $CPAN::META->instance("CPAN::Author",
5557                                                $self->cpan_userid
5558                                               )->email) {
5559                 $extra .= " <$email>";
5560             } else {
5561                 $extra .= " <no email>";
5562             }
5563             $extra .= ")";
5564         } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
5565             push @m, sprintf "    %-12s %s\n", $_, $self->fullname;
5566             next;
5567         }
5568         next unless defined $ro->{$_};
5569         push @m, sprintf "    %-12s %s%s\n", $_, $ro->{$_}, $extra;
5570     }
5571   KEY: for (sort keys %$self) {
5572         next if m/^(ID|RO)$/;
5573         unless (defined $self->{$_}) {
5574             delete $self->{$_};
5575             next KEY;
5576         }
5577         if (ref($self->{$_}) eq "ARRAY") {
5578             push @m, sprintf "    %-12s %s\n", $_, "@{$self->{$_}}";
5579         } elsif (ref($self->{$_}) eq "HASH") {
5580             my $value;
5581             if (/^CONTAINSMODS$/) {
5582                 $value = join(" ",sort keys %{$self->{$_}});
5583             } elsif (/^prereq_pm$/) {
5584                 my @value;
5585                 my $v = $self->{$_};
5586                 for my $x (sort keys %$v) {
5587                     my @svalue;
5588                     for my $y (sort keys %{$v->{$x}}) {
5589                         push @svalue, "$y=>$v->{$x}{$y}";
5590                     }
5591                     push @value, "$x\:" . join ",", @svalue if @svalue;
5592                 }
5593                 $value = join ";", @value;
5594             } else {
5595                 $value = $self->{$_};
5596             }
5597             push @m, sprintf(
5598                              "    %-12s %s\n",
5599                              $_,
5600                              $value,
5601                             );
5602         } else {
5603             push @m, sprintf "    %-12s %s\n", $_, $self->{$_};
5604         }
5605     }
5606     join "", @m, "\n";
5607 }
5608
5609 #-> sub CPAN::InfoObj::fullname ;
5610 sub fullname {
5611     my($self) = @_;
5612     $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
5613 }
5614
5615 #-> sub CPAN::InfoObj::dump ;
5616 sub dump {
5617     my($self, $what) = @_;
5618     unless ($CPAN::META->has_inst("Data::Dumper")) {
5619         $CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
5620     }
5621     local $Data::Dumper::Sortkeys;
5622     $Data::Dumper::Sortkeys = 1;
5623     my $out = Data::Dumper::Dumper($what ? eval $what : $self);
5624     if (length $out > 100000) {
5625         my $fh_pager = FileHandle->new;
5626         local($SIG{PIPE}) = "IGNORE";
5627         my $pager = $CPAN::Config->{'pager'} || "cat";
5628         $fh_pager->open("|$pager")
5629             or die "Could not open pager $pager\: $!";
5630         $fh_pager->print($out);
5631         close $fh_pager;
5632     } else {
5633         $CPAN::Frontend->myprint($out);
5634     }
5635 }
5636
5637 package CPAN::Author;
5638 use strict;
5639
5640 #-> sub CPAN::Author::force
5641 sub force {
5642     my $self = shift;
5643     $self->{force}++;
5644 }
5645
5646 #-> sub CPAN::Author::force
5647 sub unforce {
5648     my $self = shift;
5649     delete $self->{force};
5650 }
5651
5652 #-> sub CPAN::Author::id
5653 sub id {
5654     my $self = shift;
5655     my $id = $self->{ID};
5656     $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
5657     $id;
5658 }
5659
5660 #-> sub CPAN::Author::as_glimpse ;
5661 sub as_glimpse {
5662     my($self) = @_;
5663     my(@m);
5664     my $class = ref($self);
5665     $class =~ s/^CPAN:://;
5666     push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
5667                      $class,
5668                      $self->{ID},
5669                      $self->fullname,
5670                      $self->email);
5671     join "", @m;
5672 }
5673
5674 #-> sub CPAN::Author::fullname ;
5675 sub fullname {
5676     shift->ro->{FULLNAME};
5677 }
5678 *name = \&fullname;
5679
5680 #-> sub CPAN::Author::email ;
5681 sub email    { shift->ro->{EMAIL}; }
5682
5683 #-> sub CPAN::Author::ls ;
5684 sub ls {
5685     my $self = shift;
5686     my $glob = shift || "";
5687     my $silent = shift || 0;
5688     my $id = $self->id;
5689
5690     # adapted from CPAN::Distribution::verifyCHECKSUM ;
5691     my(@csf); # chksumfile
5692     @csf = $self->id =~ /(.)(.)(.*)/;
5693     $csf[1] = join "", @csf[0,1];
5694     $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
5695     my(@dl);
5696     @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
5697     unless (grep {$_->[2] eq $csf[1]} @dl) {
5698         $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
5699         return;
5700     }
5701     @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
5702     unless (grep {$_->[2] eq $csf[2]} @dl) {
5703         $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
5704         return;
5705     }
5706     @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
5707     if ($glob) {
5708         if ($CPAN::META->has_inst("Text::Glob")) {
5709             my $rglob = Text::Glob::glob_to_regex($glob);
5710             @dl = grep { $_->[2] =~ /$rglob/ } @dl;
5711         } else {
5712             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
5713         }
5714     }
5715     unless ($silent >= 2) {
5716         $CPAN::Frontend->myprint(join "", map {
5717             sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
5718         } sort { $a->[2] cmp $b->[2] } @dl);
5719     }
5720     @dl;
5721 }
5722
5723 # returns an array of arrays, the latter contain (size,mtime,filename)
5724 #-> sub CPAN::Author::dir_listing ;
5725 sub dir_listing {
5726     my $self = shift;
5727     my $chksumfile = shift;
5728     my $recursive = shift;
5729     my $may_ftp = shift;
5730
5731     my $lc_want =
5732         File::Spec->catfile($CPAN::Config->{keep_source_where},
5733                             "authors", "id", @$chksumfile);
5734
5735     my $fh;
5736
5737     # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
5738     # hazard.  (Without GPG installed they are not that much better,
5739     # though.)
5740     $fh = FileHandle->new;
5741     if (open($fh, $lc_want)) {
5742         my $line = <$fh>; close $fh;
5743         unlink($lc_want) unless $line =~ /PGP/;
5744     }
5745
5746     local($") = "/";
5747     # connect "force" argument with "index_expire".
5748     my $force = $self->{force};
5749     if (my @stat = stat $lc_want) {
5750         $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
5751     }
5752     my $lc_file;
5753     if ($may_ftp) {
5754         $lc_file = CPAN::FTP->localize(
5755                                        "authors/id/@$chksumfile",
5756                                        $lc_want,
5757                                        $force,
5758                                       );
5759         unless ($lc_file) {
5760             $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
5761             $chksumfile->[-1] .= ".gz";
5762             $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
5763                                            "$lc_want.gz",1);
5764             if ($lc_file) {
5765                 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
5766                 eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
5767             } else {
5768                 return;
5769             }
5770         }
5771     } else {
5772         $lc_file = $lc_want;
5773         # we *could* second-guess and if the user has a file: URL,
5774         # then we could look there. But on the other hand, if they do
5775         # have a file: URL, wy did they choose to set
5776         # $CPAN::Config->{show_upload_date} to false?
5777     }
5778
5779     # adapted from CPAN::Distribution::CHECKSUM_check_file ;
5780     $fh = FileHandle->new;
5781     my($cksum);
5782     if (open $fh, $lc_file) {
5783         local($/);
5784         my $eval = <$fh>;
5785         $eval =~ s/\015?\012/\n/g;
5786         close $fh;
5787         my($comp) = Safe->new();
5788         $cksum = $comp->reval($eval);
5789         if ($@) {
5790             rename $lc_file, "$lc_file.bad";
5791             Carp::confess($@) if $@;
5792         }
5793     } elsif ($may_ftp) {
5794         Carp::carp "Could not open '$lc_file' for reading.";
5795     } else {
5796         # Maybe should warn: "You may want to set show_upload_date to a true value"
5797         return;
5798     }
5799     my(@result,$f);
5800     for $f (sort keys %$cksum) {
5801         if (exists $cksum->{$f}{isdir}) {
5802             if ($recursive) {
5803                 my(@dir) = @$chksumfile;
5804                 pop @dir;
5805                 push @dir, $f, "CHECKSUMS";
5806                 push @result, map {
5807                     [$_->[0], $_->[1], "$f/$_->[2]"]
5808                 } $self->dir_listing(\@dir,1,$may_ftp);
5809             } else {
5810                 push @result, [ 0, "-", $f ];
5811             }
5812         } else {
5813             push @result, [
5814                            ($cksum->{$f}{"size"}||0),
5815                            $cksum->{$f}{"mtime"}||"---",
5816                            $f
5817                           ];
5818         }
5819     }
5820     @result;
5821 }
5822
5823 #-> sub CPAN::Author::reports
5824 sub reports {
5825     $CPAN::Frontend->mywarn("reports on authors not implemented.
5826 Please file a bugreport if you need this.\n");
5827 }
5828
5829 package CPAN::Distribution;
5830 use strict;
5831
5832 # Accessors
5833 sub cpan_comment {
5834     my $self = shift;
5835     my $ro = $self->ro or return;
5836     $ro->{CPAN_COMMENT}
5837 }
5838
5839 #-> CPAN::Distribution::undelay
5840 sub undelay {
5841     my $self = shift;
5842     for my $delayer (
5843                      "configure_requires_later",
5844                      "configure_requires_later_for",
5845                      "later",
5846                      "later_for",
5847                     ) {
5848         delete $self->{$delayer};
5849     }
5850 }
5851
5852 #-> CPAN::Distribution::is_dot_dist
5853 sub is_dot_dist {
5854     my($self) = @_;
5855     return substr($self->id,-1,1) eq ".";
5856 }
5857
5858 # add the A/AN/ stuff
5859 #-> CPAN::Distribution::normalize
5860 sub normalize {
5861     my($self,$s) = @_;
5862     $s = $self->id unless defined $s;
5863     if (substr($s,-1,1) eq ".") {
5864         # using a global because we are sometimes called as static method
5865         if (!$CPAN::META->{LOCK}
5866             && !$CPAN::Have_warned->{"$s is unlocked"}++
5867            ) {
5868             $CPAN::Frontend->mywarn("You are visiting the local directory
5869   '$s'
5870   without lock, take care that concurrent processes do not do likewise.\n");
5871             $CPAN::Frontend->mysleep(1);
5872         }
5873         if ($s eq ".") {
5874             $s = "$CPAN::iCwd/.";
5875         } elsif (File::Spec->file_name_is_absolute($s)) {
5876         } elsif (File::Spec->can("rel2abs")) {
5877             $s = File::Spec->rel2abs($s);
5878         } else {
5879             $CPAN::Frontend->mydie("Your File::Spec is too old, please upgrade File::Spec");
5880         }
5881         CPAN->debug("s[$s]") if $CPAN::DEBUG;
5882         unless ($CPAN::META->exists("CPAN::Distribution", $s)) {
5883             for ($CPAN::META->instance("CPAN::Distribution", $s)) {
5884                 $_->{build_dir} = $s;
5885                 $_->{archived} = "local_directory";
5886                 $_->{unwrapped} = CPAN::Distrostatus->new("YES -- local_directory");
5887             }
5888         }
5889     } elsif (
5890         $s =~ tr|/|| == 1
5891         or
5892         $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
5893        ) {
5894         return $s if $s =~ m:^N/A|^Contact Author: ;
5895         $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
5896             $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
5897         CPAN->debug("s[$s]") if $CPAN::DEBUG;
5898     }
5899     $s;
5900 }
5901
5902 #-> sub CPAN::Distribution::author ;
5903 sub author {
5904     my($self) = @_;
5905     my($authorid);
5906     if (substr($self->id,-1,1) eq ".") {
5907         $authorid = "LOCAL";
5908     } else {
5909         ($authorid) = $self->pretty_id =~ /^([\w\-]+)/;
5910     }
5911     CPAN::Shell->expand("Author",$authorid);
5912 }
5913
5914 # tries to get the yaml from CPAN instead of the distro itself:
5915 # EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels
5916 sub fast_yaml {
5917     my($self) = @_;
5918     my $meta = $self->pretty_id;
5919     $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/;
5920     my(@ls) = CPAN::Shell->globls($meta);
5921     my $norm = $self->normalize($meta);
5922
5923     my($local_file);
5924     my($local_wanted) =
5925         File::Spec->catfile(
5926                             $CPAN::Config->{keep_source_where},
5927                             "authors",
5928                             "id",
5929                             split(/\//,$norm)
5930                            );
5931     $self->debug("Doing localize") if $CPAN::DEBUG;
5932     unless ($local_file =
5933             CPAN::FTP->localize("authors/id/$norm",
5934                                 $local_wanted)) {
5935         $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n");
5936     }
5937     my $yaml = CPAN->_yaml_loadfile($local_file)->[0];
5938 }
5939
5940 #-> sub CPAN::Distribution::cpan_userid
5941 sub cpan_userid {
5942     my $self = shift;
5943     if ($self->{ID} =~ m{[A-Z]/[A-Z\-]{2}/([A-Z\-]+)/}) {
5944         return $1;
5945     }
5946     return $self->SUPER::cpan_userid;
5947 }
5948
5949 #-> sub CPAN::Distribution::pretty_id
5950 sub pretty_id {
5951     my $self = shift;
5952     my $id = $self->id;
5953     return $id unless $id =~ m|^./../|;
5954     substr($id,5);
5955 }
5956
5957 #-> sub CPAN::Distribution::base_id
5958 sub base_id {
5959     my $self = shift;
5960     my $id = $self->pretty_id();
5961     my $base_id = File::Basename::basename($id);
5962     $base_id =~ s{\.(?:tar\.(bz2|gz|Z)|t(?:gz|bz)|zip)$}{}i;
5963     return $base_id;
5964 }
5965
5966 # mark as dirty/clean for the sake of recursion detection. $color=1
5967 # means "in use", $color=0 means "not in use anymore". $color=2 means
5968 # we have determined prereqs now and thus insist on passing this
5969 # through (at least) once again.
5970
5971 #-> sub CPAN::Distribution::color_cmd_tmps ;
5972 sub color_cmd_tmps {
5973     my($self) = shift;
5974     my($depth) = shift || 0;
5975     my($color) = shift || 0;
5976     my($ancestors) = shift || [];
5977     # a distribution needs to recurse into its prereq_pms
5978
5979     return if exists $self->{incommandcolor}
5980         && $color==1
5981         && $self->{incommandcolor}==$color;
5982     if ($depth>=$CPAN::MAX_RECURSION) {
5983         die(CPAN::Exception::RecursiveDependency->new($ancestors));
5984     }
5985     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5986     my $prereq_pm = $self->prereq_pm;
5987     if (defined $prereq_pm) {
5988       PREREQ: for my $pre (keys %{$prereq_pm->{requires}||{}},
5989                            keys %{$prereq_pm->{build_requires}||{}}) {
5990             next PREREQ if $pre eq "perl";
5991             my $premo;
5992             unless ($premo = CPAN::Shell->expand("Module",$pre)) {
5993                 $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n");
5994                 $CPAN::Frontend->mysleep(2);
5995                 next PREREQ;
5996             }
5997             $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5998         }
5999     }
6000     if ($color==0) {
6001         delete $self->{sponsored_mods};
6002
6003         # as we are at the end of a command, we'll give up this
6004         # reminder of a broken test. Other commands may test this guy
6005         # again. Maybe 'badtestcnt' should be renamed to
6006         # 'make_test_failed_within_command'?
6007         delete $self->{badtestcnt};
6008     }
6009     $self->{incommandcolor} = $color;
6010 }
6011
6012 #-> sub CPAN::Distribution::as_string ;
6013 sub as_string {
6014     my $self = shift;
6015     $self->containsmods;
6016     $self->upload_date;
6017     $self->SUPER::as_string(@_);
6018 }
6019
6020 #-> sub CPAN::Distribution::containsmods ;
6021 sub containsmods {
6022     my $self = shift;
6023     return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
6024     my $dist_id = $self->{ID};
6025     for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
6026         my $mod_file = $mod->cpan_file or next;
6027         my $mod_id = $mod->{ID} or next;
6028         # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
6029         # sleep 1;
6030         if ($CPAN::Signal) {
6031             delete $self->{CONTAINSMODS};
6032             return;
6033         }
6034         $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
6035     }
6036     keys %{$self->{CONTAINSMODS}||={}};
6037 }
6038
6039 #-> sub CPAN::Distribution::upload_date ;
6040 sub upload_date {
6041     my $self = shift;
6042     return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
6043     my(@local_wanted) = split(/\//,$self->id);
6044     my $filename = pop @local_wanted;
6045     push @local_wanted, "CHECKSUMS";
6046     my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
6047     return unless $author;
6048     my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
6049     return unless @dl;
6050     my($dirent) = grep { $_->[2] eq $filename } @dl;
6051     # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
6052     return unless $dirent->[1];
6053     return $self->{UPLOAD_DATE} = $dirent->[1];
6054 }
6055
6056 #-> sub CPAN::Distribution::uptodate ;
6057 sub uptodate {
6058     my($self) = @_;
6059     my $c;
6060     foreach $c ($self->containsmods) {
6061         my $obj = CPAN::Shell->expandany($c);
6062         unless ($obj->uptodate) {
6063             my $id = $self->pretty_id;
6064             $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG;
6065             return 0;
6066         }
6067     }
6068     return 1;
6069 }
6070
6071 #-> sub CPAN::Distribution::called_for ;
6072 sub called_for {
6073     my($self,$id) = @_;
6074     $self->{CALLED_FOR} = $id if defined $id;
6075     return $self->{CALLED_FOR};
6076 }
6077
6078 #-> sub CPAN::Distribution::get ;
6079 sub get {
6080     my($self) = @_;
6081     $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
6082     if (my $goto = $self->prefs->{goto}) {
6083         $CPAN::Frontend->mywarn
6084             (sprintf(
6085                      "delegating to '%s' as specified in prefs file '%s' doc %d\n",
6086                      $goto,
6087                      $self->{prefs_file},
6088                      $self->{prefs_file_doc},
6089                     ));
6090         return $self->goto($goto);
6091     }
6092     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
6093                            ? $ENV{PERL5LIB}
6094                            : ($ENV{PERLLIB} || "");
6095
6096     $CPAN::META->set_perl5lib;
6097     local $ENV{MAKEFLAGS}; # protect us from outer make calls
6098
6099   EXCUSE: {
6100         my @e;
6101         my $goodbye_message;
6102         $self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG;
6103         if ($self->prefs->{disabled}) {
6104             my $why = sprintf(
6105                               "Disabled via prefs file '%s' doc %d",
6106                               $self->{prefs_file},
6107                               $self->{prefs_file_doc},
6108                              );
6109             push @e, $why;
6110             $self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
6111             $goodbye_message = "[disabled] -- NA $why";
6112             # note: not intended to be persistent but at least visible
6113             # during this session
6114         } else {
6115             if (exists $self->{build_dir} && -d $self->{build_dir}
6116                 && ($self->{modulebuild}||$self->{writemakefile})
6117                ) {
6118                 # this deserves print, not warn:
6119                 $CPAN::Frontend->myprint("  Has already been unwrapped into directory ".
6120                                          "$self->{build_dir}\n"
6121                                         );
6122                 return 1;
6123             }
6124
6125             # although we talk about 'force' we shall not test on
6126             # force directly. New model of force tries to refrain from
6127             # direct checking of force.
6128             exists $self->{unwrapped} and (
6129                                            UNIVERSAL::can($self->{unwrapped},"failed") ?
6130                                            $self->{unwrapped}->failed :
6131                                            $self->{unwrapped} =~ /^NO/
6132                                           )
6133                 and push @e, "Unwrapping had some problem, won't try again without force";
6134         }
6135         if (@e) {
6136             $CPAN::Frontend->mywarn(join "", map {"$_\n"} @e);
6137             if ($goodbye_message) {
6138                  $self->goodbye($goodbye_message);
6139             }
6140             return;
6141         }
6142     }
6143     my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
6144
6145     my($local_file);
6146     unless ($self->{build_dir} && -d $self->{build_dir}) {
6147         $self->get_file_onto_local_disk;
6148         return if $CPAN::Signal;
6149         $self->check_integrity;
6150         return if $CPAN::Signal;
6151         (my $packagedir,$local_file) = $self->run_preps_on_packagedir;
6152         $packagedir ||= $self->{build_dir};
6153         $self->{build_dir} = $packagedir;
6154     }
6155
6156     if ($CPAN::Signal) {
6157         $self->safe_chdir($sub_wd);
6158         return;
6159     }
6160     return $self->run_MM_or_MB($local_file);
6161 }
6162
6163 #-> CPAN::Distribution::get_file_onto_local_disk
6164 sub get_file_onto_local_disk {
6165     my($self) = @_;
6166
6167     return if $self->is_dot_dist;
6168     my($local_file);
6169     my($local_wanted) =
6170         File::Spec->catfile(
6171                             $CPAN::Config->{keep_source_where},
6172                             "authors",
6173                             "id",
6174                             split(/\//,$self->id)
6175                            );
6176
6177     $self->debug("Doing localize") if $CPAN::DEBUG;
6178     unless ($local_file =
6179             CPAN::FTP->localize("authors/id/$self->{ID}",
6180                                 $local_wanted)) {
6181         my $note = "";
6182         if ($CPAN::Index::DATE_OF_02) {
6183             $note = "Note: Current database in memory was generated ".
6184                 "on $CPAN::Index::DATE_OF_02\n";
6185         }
6186         $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
6187     }
6188
6189     $self->debug("local_wanted[$local_wanted]local_file[$local_file]") if $CPAN::DEBUG;
6190     $self->{localfile} = $local_file;
6191 }
6192
6193
6194 #-> CPAN::Distribution::check_integrity
6195 sub check_integrity {
6196     my($self) = @_;
6197
6198     return if $self->is_dot_dist;
6199     if ($CPAN::META->has_inst("Digest::SHA")) {
6200         $self->debug("Digest::SHA is installed, verifying");
6201         $self->verifyCHECKSUM;
6202     } else {
6203         $self->debug("Digest::SHA is NOT installed");
6204     }
6205 }
6206
6207 #-> CPAN::Distribution::run_preps_on_packagedir
6208 sub run_preps_on_packagedir {
6209     my($self) = @_;
6210     return if $self->is_dot_dist;
6211
6212     $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
6213     my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
6214     $self->safe_chdir($builddir);
6215     $self->debug("Removing tmp-$$") if $CPAN::DEBUG;
6216     File::Path::rmtree("tmp-$$");
6217     unless (mkdir "tmp-$$", 0755) {
6218         $CPAN::Frontend->unrecoverable_error(<<EOF);
6219 Couldn't mkdir '$builddir/tmp-$$': $!
6220
6221 Cannot continue: Please find the reason why I cannot make the
6222 directory
6223 $builddir/tmp-$$
6224 and fix the problem, then retry.
6225
6226 EOF
6227     }
6228     if ($CPAN::Signal) {
6229         return;
6230     }
6231     $self->safe_chdir("tmp-$$");
6232
6233     #
6234     # Unpack the goods
6235     #
6236     my $local_file = $self->{localfile};
6237     my $ct = eval{CPAN::Tarzip->new($local_file)};
6238     unless ($ct) {
6239         $self->{unwrapped} = CPAN::Distrostatus->new("NO");
6240         delete $self->{build_dir};
6241         return;
6242     }
6243     if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i) {
6244         $self->{was_uncompressed}++ unless eval{$ct->gtest()};
6245         $self->untar_me($ct);
6246     } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
6247         $self->unzip_me($ct);
6248     } else {
6249         $self->{was_uncompressed}++ unless $ct->gtest();
6250         $local_file = $self->handle_singlefile($local_file);
6251     }
6252
6253     # we are still in the tmp directory!
6254     # Let's check if the package has its own directory.
6255     my $dh = DirHandle->new(File::Spec->curdir)
6256         or Carp::croak("Couldn't opendir .: $!");
6257     my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
6258     $dh->close;
6259     my ($packagedir);
6260     # XXX here we want in each branch File::Temp to protect all build_dir directories
6261     if (CPAN->has_usable("File::Temp")) {
6262         my $tdir_base;
6263         my $from_dir;
6264         my @dirents;
6265         if (@readdir == 1 && -d $readdir[0]) {
6266             $tdir_base = $readdir[0];
6267             $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]);
6268             my $dh2 = DirHandle->new($from_dir)
6269                 or Carp::croak("Couldn't opendir $from_dir: $!");
6270             @dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC??
6271         } else {
6272             my $userid = $self->cpan_userid;
6273             CPAN->debug("userid[$userid]");
6274             if (!$userid or $userid eq "N/A") {
6275                 $userid = "anon";
6276             }
6277             $tdir_base = $userid;
6278             $from_dir = File::Spec->curdir;
6279             @dirents = @readdir;
6280         }
6281         $packagedir = File::Temp::tempdir(
6282                                           "$tdir_base-XXXXXX",
6283                                           DIR => $builddir,
6284                                           CLEANUP => 0,
6285                                          );
6286         my $f;
6287         for $f (@dirents) { # is already without "." and ".."
6288             my $from = File::Spec->catdir($from_dir,$f);
6289             my $to = File::Spec->catdir($packagedir,$f);
6290             unless (File::Copy::move($from,$to)) {
6291                 my $err = $!;
6292                 $from = File::Spec->rel2abs($from);
6293                 Carp::confess("Couldn't move $from to $to: $err");
6294             }
6295         }
6296     } else { # older code below, still better than nothing when there is no File::Temp
6297         my($distdir);
6298         if (@readdir == 1 && -d $readdir[0]) {
6299             $distdir = $readdir[0];
6300             $packagedir = File::Spec->catdir($builddir,$distdir);
6301             $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
6302                 if $CPAN::DEBUG;
6303             -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
6304                                                         "$packagedir\n");
6305             File::Path::rmtree($packagedir);
6306             unless (File::Copy::move($distdir,$packagedir)) {
6307                 $CPAN::Frontend->unrecoverable_error(<<EOF);
6308 Couldn't move '$distdir' to '$packagedir': $!
6309
6310 Cannot continue: Please find the reason why I cannot move
6311 $builddir/tmp-$$/$distdir
6312 to
6313 $packagedir
6314 and fix the problem, then retry
6315
6316 EOF
6317             }
6318             $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
6319                                  $distdir,
6320                                  $packagedir,
6321                                  -e $packagedir,
6322                                  -d $packagedir,
6323                                 )) if $CPAN::DEBUG;
6324         } else {
6325             my $userid = $self->cpan_userid;
6326             CPAN->debug("userid[$userid]") if $CPAN::DEBUG;
6327             if (!$userid or $userid eq "N/A") {
6328                 $userid = "anon";
6329             }
6330             my $pragmatic_dir = $userid . '000';
6331             $pragmatic_dir =~ s/\W_//g;
6332             $pragmatic_dir++ while -d "../$pragmatic_dir";
6333             $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
6334             $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
6335             File::Path::mkpath($packagedir);
6336             my($f);
6337             for $f (@readdir) { # is already without "." and ".."
6338                 my $to = File::Spec->catdir($packagedir,$f);
6339                 File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
6340             }
6341         }
6342     }
6343     $self->{build_dir} = $packagedir;
6344     $self->safe_chdir($builddir);
6345     File::Path::rmtree("tmp-$$");
6346
6347     $self->safe_chdir($packagedir);
6348     $self->_signature_business();
6349     $self->safe_chdir($builddir);
6350
6351     return($packagedir,$local_file);
6352 }
6353
6354 #-> sub CPAN::Distribution::parse_meta_yml ;
6355 sub parse_meta_yml {
6356     my($self) = @_;
6357     my $build_dir = $self->{build_dir} or die "PANIC: cannot parse yaml without a build_dir";
6358     my $yaml = File::Spec->catfile($build_dir,"META.yml");
6359     $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
6360     return unless -f $yaml;
6361     my $early_yaml;
6362     eval {
6363         require Parse::Metayaml; # hypothetical
6364         $early_yaml = Parse::Metayaml::LoadFile($yaml)->[0];
6365     };
6366     unless ($early_yaml) {
6367         eval { $early_yaml = CPAN->_yaml_loadfile($yaml)->[0]; };
6368     }
6369     unless ($early_yaml) {
6370         return;
6371     }
6372     return $early_yaml;
6373 }
6374
6375 #-> sub CPAN::Distribution::satisfy_configure_requires ;
6376 sub satisfy_configure_requires {
6377     my($self) = @_;
6378     my $enable_configure_requires = 1;
6379     if (!$enable_configure_requires) {
6380         return 1;
6381         # if we return 1 here, everything is as before we introduced
6382         # configure_requires that means, things with
6383         # configure_requires simply fail, all others succeed
6384     }
6385     my @prereq = $self->unsat_prereq("configure_requires_later") or return 1;
6386     if ($self->{configure_requires_later}) {
6387         for my $k (keys %{$self->{configure_requires_later_for}||{}}) {
6388             if ($self->{configure_requires_later_for}{$k}>1) {
6389                 # we must not come here a second time
6390                 $CPAN::Frontend->mywarn("Panic: Some prerequisites is not available, please investigate...");
6391                 require YAML::Syck;
6392                 $CPAN::Frontend->mydie
6393                     (
6394                      YAML::Syck::Dump
6395                      ({self=>$self, prereq=>\@prereq})
6396                     );
6397             }
6398         }
6399     }
6400     if ($prereq[0][0] eq "perl") {
6401         my $need = "requires perl '$prereq[0][1]'";
6402         my $id = $self->pretty_id;
6403         $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
6404         $self->{make} = CPAN::Distrostatus->new("NO $need");
6405         $self->store_persistent_state;
6406         return $self->goodbye("[prereq] -- NOT OK");
6407     } else {
6408         my $follow = eval {
6409             $self->follow_prereqs("configure_requires_later", @prereq);
6410         };
6411         if (0) {
6412         } elsif ($follow) {
6413             return;
6414         } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
6415             $CPAN::Frontend->mywarn($@);
6416             return $self->goodbye("[depend] -- NOT OK");
6417         }
6418     }
6419     die "never reached";
6420 }
6421
6422 #-> sub CPAN::Distribution::run_MM_or_MB ;
6423 sub run_MM_or_MB {
6424     my($self,$local_file) = @_;
6425     $self->satisfy_configure_requires() or return;
6426     my($mpl) = File::Spec->catfile($self->{build_dir},"Makefile.PL");
6427     my($mpl_exists) = -f $mpl;
6428     unless ($mpl_exists) {
6429         # NFS has been reported to have racing problems after the
6430         # renaming of a directory in some environments.
6431         # This trick helps.
6432         $CPAN::Frontend->mysleep(1);
6433         my $mpldh = DirHandle->new($self->{build_dir})
6434             or Carp::croak("Couldn't opendir $self->{build_dir}: $!");
6435         $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
6436         $mpldh->close;
6437     }
6438     my $prefer_installer = "eumm"; # eumm|mb
6439     if (-f File::Spec->catfile($self->{build_dir},"Build.PL")) {
6440         if ($mpl_exists) { # they *can* choose
6441             if ($CPAN::META->has_inst("Module::Build")) {
6442                 $prefer_installer = CPAN::HandleConfig->prefs_lookup($self,
6443                                                                      q{prefer_installer});
6444             }
6445         } else {
6446             $prefer_installer = "mb";
6447         }
6448     }
6449     return unless $self->patch;
6450     if (lc($prefer_installer) eq "rand") {
6451         $prefer_installer = rand()<.5 ? "eumm" : "mb";
6452     }
6453     if (lc($prefer_installer) eq "mb") {
6454         $self->{modulebuild} = 1;
6455     } elsif ($self->{archived} eq "patch") {
6456         # not an edge case, nothing to install for sure
6457         my $why = "A patch file cannot be installed";
6458         $CPAN::Frontend->mywarn("Refusing to handle this file: $why\n");
6459         $self->{writemakefile} = CPAN::Distrostatus->new("NO $why");
6460     } elsif (! $mpl_exists) {
6461         $self->_edge_cases($mpl,$local_file);
6462     }
6463     if ($self->{build_dir}
6464         &&
6465         $CPAN::Config->{build_dir_reuse}
6466        ) {
6467         $self->store_persistent_state;
6468     }
6469     return $self;
6470 }
6471
6472 #-> CPAN::Distribution::store_persistent_state
6473 sub store_persistent_state {
6474     my($self) = @_;
6475     my $dir = $self->{build_dir};
6476     unless (File::Spec->canonpath(File::Basename::dirname($dir))
6477             eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
6478         $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
6479                                 "will not store persistent state\n");
6480         return;
6481     }
6482     my $file = sprintf "%s.yml", $dir;
6483     my $yaml_module = CPAN::_yaml_module;
6484     if ($CPAN::META->has_inst($yaml_module)) {
6485         CPAN->_yaml_dumpfile(
6486                              $file,
6487                              {
6488                               time => time,
6489                               perl => CPAN::_perl_fingerprint,
6490                               distribution => $self,
6491                              }
6492                             );
6493     } else {
6494         $CPAN::Frontend->myprint("Warning (usually harmless): '$yaml_module' not installed, ".
6495                                 "will not store persistent state\n");
6496     }
6497 }
6498
6499 #-> CPAN::Distribution::try_download
6500 sub try_download {
6501     my($self,$patch) = @_;
6502     my $norm = $self->normalize($patch);
6503     my($local_wanted) =
6504         File::Spec->catfile(
6505                             $CPAN::Config->{keep_source_where},
6506                             "authors",
6507                             "id",
6508                             split(/\//,$norm),
6509                            );
6510     $self->debug("Doing localize") if $CPAN::DEBUG;
6511     return CPAN::FTP->localize("authors/id/$norm",
6512                                $local_wanted);
6513 }
6514
6515 {
6516     my $stdpatchargs = "";
6517     #-> CPAN::Distribution::patch
6518     sub patch {
6519         my($self) = @_;
6520         $self->debug("checking patches id[$self->{ID}]") if $CPAN::DEBUG;
6521         my $patches = $self->prefs->{patches};
6522         $patches ||= "";
6523         $self->debug("patches[$patches]") if $CPAN::DEBUG;
6524         if ($patches) {
6525             return unless @$patches;
6526             $self->safe_chdir($self->{build_dir});
6527             CPAN->debug("patches[$patches]") if $CPAN::DEBUG;
6528             my $patchbin = $CPAN::Config->{patch};
6529             unless ($patchbin && length $patchbin) {
6530                 $CPAN::Frontend->mydie("No external patch command configured\n\n".
6531                                        "Please run 'o conf init /patch/'\n\n");
6532             }
6533             unless (MM->maybe_command($patchbin)) {
6534                 $CPAN::Frontend->mydie("No external patch command available\n\n".
6535                                        "Please run 'o conf init /patch/'\n\n");
6536             }
6537             $patchbin = CPAN::HandleConfig->safe_quote($patchbin);
6538             local $ENV{PATCH_GET} = 0; # formerly known as -g0
6539             unless ($stdpatchargs) {
6540                 my $system = "$patchbin --version |";
6541                 local *FH;
6542                 open FH, $system or die "Could not fork '$system': $!";
6543                 local $/ = "\n";
6544                 my $pversion;
6545               PARSEVERSION: while (<FH>) {
6546                     if (/^patch\s+([\d\.]+)/) {
6547                         $pversion = $1;
6548                         last PARSEVERSION;
6549                     }
6550                 }
6551                 if ($pversion) {
6552                     $stdpatchargs = "-N --fuzz=3";
6553                 } else {
6554                     $stdpatchargs = "-N";
6555                 }
6556             }
6557             my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches");
6558             $CPAN::Frontend->myprint("Going to apply $countedpatches:\n");
6559             for my $patch (@$patches) {
6560                 unless (-f $patch) {
6561                     if (my $trydl = $self->try_download($patch)) {
6562                         $patch = $trydl;
6563                     } else {
6564                         my $fail = "Could not find patch '$patch'";
6565                         $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6566                         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6567                         delete $self->{build_dir};
6568                         return;
6569                     }
6570                 }
6571                 $CPAN::Frontend->myprint("  $patch\n");
6572                 my $readfh = CPAN::Tarzip->TIEHANDLE($patch);
6573
6574                 my $pcommand;
6575                 my $ppp = $self->_patch_p_parameter($readfh);
6576                 if ($ppp eq "applypatch") {
6577                     $pcommand = "$CPAN::Config->{applypatch} -verbose";
6578                 } else {
6579                     my $thispatchargs = join " ", $stdpatchargs, $ppp;
6580                     $pcommand = "$patchbin $thispatchargs";
6581                 }
6582
6583                 $readfh = CPAN::Tarzip->TIEHANDLE($patch); # open again
6584                 my $writefh = FileHandle->new;
6585                 $CPAN::Frontend->myprint("  $pcommand\n");
6586                 unless (open $writefh, "|$pcommand") {
6587                     my $fail = "Could not fork '$pcommand'";
6588                     $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6589                     $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6590                     delete $self->{build_dir};
6591                     return;
6592                 }
6593                 while (my $x = $readfh->READLINE) {
6594                     print $writefh $x;
6595                 }
6596                 unless (close $writefh) {
6597                     my $fail = "Could not apply patch '$patch'";
6598                     $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6599                     $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6600                     delete $self->{build_dir};
6601                     return;
6602                 }
6603             }
6604             $self->{patched}++;
6605         }
6606         return 1;
6607     }
6608 }
6609
6610 sub _patch_p_parameter {
6611     my($self,$fh) = @_;
6612     my $cnt_files   = 0;
6613     my $cnt_p0files = 0;
6614     local($_);
6615     while ($_ = $fh->READLINE) {
6616         if (
6617             $CPAN::Config->{applypatch}
6618             &&
6619             /\#\#\#\# ApplyPatch data follows \#\#\#\#/
6620            ) {
6621             return "applypatch"
6622         }
6623         next unless /^[\*\+]{3}\s(\S+)/;
6624         my $file = $1;
6625         $cnt_files++;
6626         $cnt_p0files++ if -f $file;
6627         CPAN->debug("file[$file]cnt_files[$cnt_files]cnt_p0files[$cnt_p0files]")
6628             if $CPAN::DEBUG;
6629     }
6630     return "-p1" unless $cnt_files;
6631     return $cnt_files==$cnt_p0files ? "-p0" : "-p1";
6632 }
6633
6634 #-> sub CPAN::Distribution::_edge_cases
6635 # with "configure" or "Makefile" or single file scripts
6636 sub _edge_cases {
6637     my($self,$mpl,$local_file) = @_;
6638     $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
6639                          $mpl,
6640                          CPAN::anycwd(),
6641                         )) if $CPAN::DEBUG;
6642     my $build_dir = $self->{build_dir};
6643     my($configure) = File::Spec->catfile($build_dir,"Configure");
6644     if (-f $configure) {
6645         # do we have anything to do?
6646         $self->{configure} = $configure;
6647     } elsif (-f File::Spec->catfile($build_dir,"Makefile")) {
6648         $CPAN::Frontend->mywarn(qq{
6649 Package comes with a Makefile and without a Makefile.PL.
6650 We\'ll try to build it with that Makefile then.
6651 });
6652         $self->{writemakefile} = CPAN::Distrostatus->new("YES");
6653         $CPAN::Frontend->mysleep(2);
6654     } else {
6655         my $cf = $self->called_for || "unknown";
6656         if ($cf =~ m|/|) {
6657             $cf =~ s|.*/||;
6658             $cf =~ s|\W.*||;
6659         }
6660         $cf =~ s|[/\\:]||g;     # risk of filesystem damage
6661         $cf = "unknown" unless length($cf);
6662         $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
6663   (The test -f "$mpl" returned false.)
6664   Writing one on our own (setting NAME to $cf)\a\n});
6665         $self->{had_no_makefile_pl}++;
6666         $CPAN::Frontend->mysleep(3);
6667
6668         # Writing our own Makefile.PL
6669
6670         my $script = "";
6671         if ($self->{archived} eq "maybe_pl") {
6672             my $fh = FileHandle->new;
6673             my $script_file = File::Spec->catfile($build_dir,$local_file);
6674             $fh->open($script_file)
6675                 or Carp::croak("Could not open script '$script_file': $!");
6676             local $/ = "\n";
6677             # name parsen und prereq
6678             my($state) = "poddir";
6679             my($name, $prereq) = ("", "");
6680             while (<$fh>) {
6681                 if ($state eq "poddir" && /^=head\d\s+(\S+)/) {
6682                     if ($1 eq 'NAME') {
6683                         $state = "name";
6684                     } elsif ($1 eq 'PREREQUISITES') {
6685                         $state = "prereq";
6686                     }
6687                 } elsif ($state =~ m{^(name|prereq)$}) {
6688                     if (/^=/) {
6689                         $state = "poddir";
6690                     } elsif (/^\s*$/) {
6691                         # nop
6692                     } elsif ($state eq "name") {
6693                         if ($name eq "") {
6694                             ($name) = /^(\S+)/;
6695                             $state = "poddir";
6696                         }
6697                     } elsif ($state eq "prereq") {
6698                         $prereq .= $_;
6699                     }
6700                 } elsif (/^=cut\b/) {
6701                     last;
6702                 }
6703             }
6704             $fh->close;
6705
6706             for ($name) {
6707                 s{.*<}{};       # strip X<...>
6708                 s{>.*}{};
6709             }
6710             chomp $prereq;
6711             $prereq = join " ", split /\s+/, $prereq;
6712             my($PREREQ_PM) = join("\n", map {
6713                 s{.*<}{};       # strip X<...>
6714                 s{>.*}{};
6715                 if (/[\s\'\"]/) { # prose?
6716                 } else {
6717                     s/[^\w:]$//; # period?
6718                     " "x28 . "'$_' => 0,";
6719                 }
6720             } split /\s*,\s*/, $prereq);
6721
6722             $script = "
6723               EXE_FILES => ['$name'],
6724               PREREQ_PM => {
6725 $PREREQ_PM
6726                            },
6727 ";
6728             if ($name) {
6729                 my $to_file = File::Spec->catfile($build_dir, $name);
6730                 rename $script_file, $to_file
6731                     or die "Can't rename $script_file to $to_file: $!";
6732             }
6733         }
6734
6735         my $fh = FileHandle->new;
6736         $fh->open(">$mpl")
6737             or Carp::croak("Could not open >$mpl: $!");
6738         $fh->print(
6739                    qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
6740 # because there was no Makefile.PL supplied.
6741 # Autogenerated on: }.scalar localtime().qq{
6742
6743 use ExtUtils::MakeMaker;
6744 WriteMakefile(
6745               NAME => q[$cf],$script
6746              );
6747 });
6748         $fh->close;
6749     }
6750 }
6751
6752 #-> CPAN::Distribution::_signature_business
6753 sub _signature_business {
6754     my($self) = @_;
6755     my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
6756                                                       q{check_sigs});
6757     if ($check_sigs) {
6758         if ($CPAN::META->has_inst("Module::Signature")) {
6759             if (-f "SIGNATURE") {
6760                 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
6761                 my $rv = Module::Signature::verify();
6762                 if ($rv != Module::Signature::SIGNATURE_OK() and
6763                     $rv != Module::Signature::SIGNATURE_MISSING()) {
6764                     $CPAN::Frontend->mywarn(
6765                                             qq{\nSignature invalid for }.
6766                                             qq{distribution file. }.
6767                                             qq{Please investigate.\n\n}
6768                                            );
6769
6770                     my $wrap =
6771                         sprintf(qq{I'd recommend removing %s. Some error occured    }.
6772                                 qq{while checking its signature, so it could        }.
6773                                 qq{be invalid. Maybe you have configured            }.
6774                                 qq{your 'urllist' with a bad URL. Please check this }.
6775                                 qq{array with 'o conf urllist' and retry. Or        }.
6776                                 qq{examine the distribution in a subshell. Try
6777   look %s
6778 and run
6779   cpansign -v
6780 },
6781                                 $self->{localfile},
6782                                 $self->pretty_id,
6783                                );
6784                     $self->{signature_verify} = CPAN::Distrostatus->new("NO");
6785                     $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
6786                     $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
6787                 } else {
6788                     $self->{signature_verify} = CPAN::Distrostatus->new("YES");
6789                     $self->debug("Module::Signature has verified") if $CPAN::DEBUG;
6790                 }
6791             } else {
6792                 $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n});
6793             }
6794         } else {
6795             $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
6796         }
6797     }
6798 }
6799
6800 #-> CPAN::Distribution::untar_me ;
6801 sub untar_me {
6802     my($self,$ct) = @_;
6803     $self->{archived} = "tar";
6804     if ($ct->untar()) {
6805         $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6806     } else {
6807         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed");
6808     }
6809 }
6810
6811 # CPAN::Distribution::unzip_me ;
6812 sub unzip_me {
6813     my($self,$ct) = @_;
6814     $self->{archived} = "zip";
6815     if ($ct->unzip()) {
6816         $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6817     } else {
6818         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed");
6819     }
6820     return;
6821 }
6822
6823 sub handle_singlefile {
6824     my($self,$local_file) = @_;
6825
6826     if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ) {
6827         $self->{archived} = "pm";
6828     } elsif ( $local_file =~ /\.patch(\.(gz|bz2))?(?!\n)\Z/ ) {
6829         $self->{archived} = "patch";
6830     } else {
6831         $self->{archived} = "maybe_pl";
6832     }
6833
6834     my $to = File::Basename::basename($local_file);
6835     if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
6836         if (eval{CPAN::Tarzip->new($local_file)->gunzip($to)}) {
6837             $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6838         } else {
6839             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- uncompressing failed");
6840         }
6841     } else {
6842         if (File::Copy::cp($local_file,".")) {
6843             $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6844         } else {
6845             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed");
6846         }
6847     }
6848     return $to;
6849 }
6850
6851 #-> sub CPAN::Distribution::new ;
6852 sub new {
6853     my($class,%att) = @_;
6854
6855     # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
6856
6857     my $this = { %att };
6858     return bless $this, $class;
6859 }
6860
6861 #-> sub CPAN::Distribution::look ;
6862 sub look {
6863     my($self) = @_;
6864
6865     if ($^O eq 'MacOS') {
6866       $self->Mac::BuildTools::look;
6867       return;
6868     }
6869
6870     if (  $CPAN::Config->{'shell'} ) {
6871         $CPAN::Frontend->myprint(qq{
6872 Trying to open a subshell in the build directory...
6873 });
6874     } else {
6875         $CPAN::Frontend->myprint(qq{
6876 Your configuration does not define a value for subshells.
6877 Please define it with "o conf shell <your shell>"
6878 });
6879         return;
6880     }
6881     my $dist = $self->id;
6882     my $dir;
6883     unless ($dir = $self->dir) {
6884         $self->get;
6885     }
6886     unless ($dir ||= $self->dir) {
6887         $CPAN::Frontend->mywarn(qq{
6888 Could not determine which directory to use for looking at $dist.
6889 });
6890         return;
6891     }
6892     my $pwd  = CPAN::anycwd();
6893     $self->safe_chdir($dir);
6894     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
6895     {
6896         local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
6897         $ENV{CPAN_SHELL_LEVEL} += 1;
6898         my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'});
6899         unless (system($shell) == 0) {
6900             my $code = $? >> 8;
6901             $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
6902         }
6903     }
6904     $self->safe_chdir($pwd);
6905 }
6906
6907 # CPAN::Distribution::cvs_import ;
6908 sub cvs_import {
6909     my($self) = @_;
6910     $self->get;
6911     my $dir = $self->dir;
6912
6913     my $package = $self->called_for;
6914     my $module = $CPAN::META->instance('CPAN::Module', $package);
6915     my $version = $module->cpan_version;
6916
6917     my $userid = $self->cpan_userid;
6918
6919     my $cvs_dir = (split /\//, $dir)[-1];
6920     $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
6921     my $cvs_root =
6922       $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
6923     my $cvs_site_perl =
6924       $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
6925     if ($cvs_site_perl) {
6926         $cvs_dir = "$cvs_site_perl/$cvs_dir";
6927     }
6928     my $cvs_log = qq{"imported $package $version sources"};
6929     $version =~ s/\./_/g;
6930     # XXX cvs: undocumented and unclear how it was meant to work
6931     my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
6932                "$cvs_dir", $userid, "v$version");
6933
6934     my $pwd  = CPAN::anycwd();
6935     chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
6936
6937     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
6938
6939     $CPAN::Frontend->myprint(qq{@cmd\n});
6940     system(@cmd) == 0 or
6941     # XXX cvs
6942         $CPAN::Frontend->mydie("cvs import failed");
6943     chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
6944 }
6945
6946 #-> sub CPAN::Distribution::readme ;
6947 sub readme {
6948     my($self) = @_;
6949     my($dist) = $self->id;
6950     my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
6951     $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
6952     my($local_file);
6953     my($local_wanted) =
6954         File::Spec->catfile(
6955                             $CPAN::Config->{keep_source_where},
6956                             "authors",
6957                             "id",
6958                             split(/\//,"$sans.readme"),
6959                            );
6960     $self->debug("Doing localize") if $CPAN::DEBUG;
6961     $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
6962                                       $local_wanted)
6963         or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
6964
6965     if ($^O eq 'MacOS') {
6966         Mac::BuildTools::launch_file($local_file);
6967         return;
6968     }
6969
6970     my $fh_pager = FileHandle->new;
6971     local($SIG{PIPE}) = "IGNORE";
6972     my $pager = $CPAN::Config->{'pager'} || "cat";
6973     $fh_pager->open("|$pager")
6974         or die "Could not open pager $pager\: $!";
6975     my $fh_readme = FileHandle->new;
6976     $fh_readme->open($local_file)
6977         or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
6978     $CPAN::Frontend->myprint(qq{
6979 Displaying file
6980   $local_file
6981 with pager "$pager"
6982 });
6983     $fh_pager->print(<$fh_readme>);
6984     $fh_pager->close;
6985 }
6986
6987 #-> sub CPAN::Distribution::verifyCHECKSUM ;
6988 sub verifyCHECKSUM {
6989     my($self) = @_;
6990   EXCUSE: {
6991         my @e;
6992         $self->{CHECKSUM_STATUS} ||= "";
6993         $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
6994         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
6995     }
6996     my($lc_want,$lc_file,@local,$basename);
6997     @local = split(/\//,$self->id);
6998     pop @local;
6999     push @local, "CHECKSUMS";
7000     $lc_want =
7001         File::Spec->catfile($CPAN::Config->{keep_source_where},
7002                             "authors", "id", @local);
7003     local($") = "/";
7004     if (my $size = -s $lc_want) {
7005         $self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG;
7006         if ($self->CHECKSUM_check_file($lc_want,1)) {
7007             return $self->{CHECKSUM_STATUS} = "OK";
7008         }
7009     }
7010     $lc_file = CPAN::FTP->localize("authors/id/@local",
7011                                    $lc_want,1);
7012     unless ($lc_file) {
7013         $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
7014         $local[-1] .= ".gz";
7015         $lc_file = CPAN::FTP->localize("authors/id/@local",
7016                                        "$lc_want.gz",1);
7017         if ($lc_file) {
7018             $lc_file =~ s/\.gz(?!\n)\Z//;
7019             eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
7020         } else {
7021             return;
7022         }
7023     }
7024     if ($self->CHECKSUM_check_file($lc_file)) {
7025         return $self->{CHECKSUM_STATUS} = "OK";
7026     }
7027 }
7028
7029 #-> sub CPAN::Distribution::SIG_check_file ;
7030 sub SIG_check_file {
7031     my($self,$chk_file) = @_;
7032     my $rv = eval { Module::Signature::_verify($chk_file) };
7033
7034     if ($rv == Module::Signature::SIGNATURE_OK()) {
7035         $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
7036         return $self->{SIG_STATUS} = "OK";
7037     } else {
7038         $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
7039                                  qq{distribution file. }.
7040                                  qq{Please investigate.\n\n}.
7041                                  $self->as_string,
7042                                  $CPAN::META->instance(
7043                                                        'CPAN::Author',
7044                                                        $self->cpan_userid
7045                                                       )->as_string);
7046
7047         my $wrap = qq{I\'d recommend removing $chk_file. Its signature
7048 is invalid. Maybe you have configured your 'urllist' with
7049 a bad URL. Please check this array with 'o conf urllist', and
7050 retry.};
7051
7052         $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
7053     }
7054 }
7055
7056 #-> sub CPAN::Distribution::CHECKSUM_check_file ;
7057
7058 # sloppy is 1 when we have an old checksums file that maybe is good
7059 # enough
7060
7061 sub CHECKSUM_check_file {
7062     my($self,$chk_file,$sloppy) = @_;
7063     my($cksum,$file,$basename);
7064
7065     $sloppy ||= 0;
7066     $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG;
7067     my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
7068                                                       q{check_sigs});
7069     if ($check_sigs) {
7070         if ($CPAN::META->has_inst("Module::Signature")) {
7071             $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
7072             $self->SIG_check_file($chk_file);
7073         } else {
7074             $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
7075         }
7076     }
7077
7078     $file = $self->{localfile};
7079     $basename = File::Basename::basename($file);
7080     my $fh = FileHandle->new;
7081     if (open $fh, $chk_file) {
7082         local($/);
7083         my $eval = <$fh>;
7084         $eval =~ s/\015?\012/\n/g;
7085         close $fh;
7086         my($comp) = Safe->new();
7087         $cksum = $comp->reval($eval);
7088         if ($@) {
7089             rename $chk_file, "$chk_file.bad";
7090             Carp::confess($@) if $@;
7091         }
7092     } else {
7093         Carp::carp "Could not open $chk_file for reading";
7094     }
7095
7096     if (! ref $cksum or ref $cksum ne "HASH") {
7097         $CPAN::Frontend->mywarn(qq{
7098 Warning: checksum file '$chk_file' broken.
7099
7100 When trying to read that file I expected to get a hash reference
7101 for further processing, but got garbage instead.
7102 });
7103         my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
7104         $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
7105         $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken";
7106         return;
7107     } elsif (exists $cksum->{$basename}{sha256}) {
7108         $self->debug("Found checksum for $basename:" .
7109                      "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
7110
7111         open($fh, $file);
7112         binmode $fh;
7113         my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
7114         $fh->close;
7115         $fh = CPAN::Tarzip->TIEHANDLE($file);
7116
7117         unless ($eq) {
7118             my $dg = Digest::SHA->new(256);
7119             my($data,$ref);
7120             $ref = \$data;
7121             while ($fh->READ($ref, 4096) > 0) {
7122                 $dg->add($data);
7123             }
7124             my $hexdigest = $dg->hexdigest;
7125             $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
7126         }
7127
7128         if ($eq) {
7129             $CPAN::Frontend->myprint("Checksum for $file ok\n");
7130             return $self->{CHECKSUM_STATUS} = "OK";
7131         } else {
7132             $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
7133                                      qq{distribution file. }.
7134                                      qq{Please investigate.\n\n}.
7135                                      $self->as_string,
7136                                      $CPAN::META->instance(
7137                                                            'CPAN::Author',
7138                                                            $self->cpan_userid
7139                                                           )->as_string);
7140
7141             my $wrap = qq{I\'d recommend removing $file. Its
7142 checksum is incorrect. Maybe you have configured your 'urllist' with
7143 a bad URL. Please check this array with 'o conf urllist', and
7144 retry.};
7145
7146             $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
7147
7148             # former versions just returned here but this seems a
7149             # serious threat that deserves a die
7150
7151             # $CPAN::Frontend->myprint("\n\n");
7152             # sleep 3;
7153             # return;
7154         }
7155         # close $fh if fileno($fh);
7156     } else {
7157         return if $sloppy;
7158         unless ($self->{CHECKSUM_STATUS}) {
7159             $CPAN::Frontend->mywarn(qq{
7160 Warning: No checksum for $basename in $chk_file.
7161
7162 The cause for this may be that the file is very new and the checksum
7163 has not yet been calculated, but it may also be that something is
7164 going awry right now.
7165 });
7166             my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes");
7167             $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
7168         }
7169         $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file";
7170         return;
7171     }
7172 }
7173
7174 #-> sub CPAN::Distribution::eq_CHECKSUM ;
7175 sub eq_CHECKSUM {
7176     my($self,$fh,$expect) = @_;
7177     if ($CPAN::META->has_inst("Digest::SHA")) {
7178         my $dg = Digest::SHA->new(256);
7179         my($data);
7180         while (read($fh, $data, 4096)) {
7181             $dg->add($data);
7182         }
7183         my $hexdigest = $dg->hexdigest;
7184         # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
7185         return $hexdigest eq $expect;
7186     }
7187     return 1;
7188 }
7189
7190 #-> sub CPAN::Distribution::force ;
7191
7192 # Both CPAN::Modules and CPAN::Distributions know if "force" is in
7193 # effect by autoinspection, not by inspecting a global variable. One
7194 # of the reason why this was chosen to work that way was the treatment
7195 # of dependencies. They should not automatically inherit the force
7196 # status. But this has the downside that ^C and die() will return to
7197 # the prompt but will not be able to reset the force_update
7198 # attributes. We try to correct for it currently in the read_metadata
7199 # routine, and immediately before we check for a Signal. I hope this
7200 # works out in one of v1.57_53ff
7201
7202 # "Force get forgets previous error conditions"
7203
7204 #-> sub CPAN::Distribution::fforce ;
7205 sub fforce {
7206   my($self, $method) = @_;
7207   $self->force($method,1);
7208 }
7209
7210 #-> sub CPAN::Distribution::force ;
7211 sub force {
7212   my($self, $method,$fforce) = @_;
7213   my %phase_map = (
7214                    get => [
7215                            "unwrapped",
7216                            "build_dir",
7217                            "archived",
7218                            "localfile",
7219                            "CHECKSUM_STATUS",
7220                            "signature_verify",
7221                            "prefs",
7222                            "prefs_file",
7223                            "prefs_file_doc",
7224                           ],
7225                    make => [
7226                             "writemakefile",
7227                             "make",
7228                             "modulebuild",
7229                             "prereq_pm",
7230                             "prereq_pm_detected",
7231                            ],
7232                    test => [
7233                             "badtestcnt",
7234                             "make_test",
7235                            ],
7236                    install => [
7237                                "install",
7238                               ],
7239                    unknown => [
7240                                "reqtype",
7241                                "yaml_content",
7242                               ],
7243                   );
7244   my $methodmatch = 0;
7245   my $ldebug = 0;
7246  PHASE: for my $phase (qw(unknown get make test install)) { # order matters
7247       $methodmatch = 1 if $fforce || $phase eq $method;
7248       next unless $methodmatch;
7249     ATTRIBUTE: for my $att (@{$phase_map{$phase}}) {
7250           if ($phase eq "get") {
7251               if (substr($self->id,-1,1) eq "."
7252                   && $att =~ /(unwrapped|build_dir|archived)/ ) {
7253                   # cannot be undone for local distros
7254                   next ATTRIBUTE;
7255               }
7256               if ($att eq "build_dir"
7257                   && $self->{build_dir}
7258                   && $CPAN::META->{is_tested}
7259                  ) {
7260                   delete $CPAN::META->{is_tested}{$self->{build_dir}};
7261               }
7262           } elsif ($phase eq "test") {
7263               if ($att eq "make_test"
7264                   && $self->{make_test}
7265                   && $self->{make_test}{COMMANDID}
7266                   && $self->{make_test}{COMMANDID} == $CPAN::CurrentCommandId
7267                  ) {
7268                   # endless loop too likely
7269                   next ATTRIBUTE;
7270               }
7271           }
7272           delete $self->{$att};
7273           if ($ldebug || $CPAN::DEBUG) {
7274               # local $CPAN::DEBUG = 16; # Distribution
7275               CPAN->debug(sprintf "id[%s]phase[%s]att[%s]", $self->id, $phase, $att);
7276           }
7277       }
7278   }
7279   if ($method && $method =~ /make|test|install/) {
7280     $self->{force_update} = 1; # name should probably have been force_install
7281   }
7282 }
7283
7284 #-> sub CPAN::Distribution::notest ;
7285 sub notest {
7286   my($self, $method) = @_;
7287   # $CPAN::Frontend->mywarn("XDEBUG: set notest for $self $method");
7288   $self->{"notest"}++; # name should probably have been force_install
7289 }
7290
7291 #-> sub CPAN::Distribution::unnotest ;
7292 sub unnotest {
7293   my($self) = @_;
7294   # warn "XDEBUG: deleting notest";
7295   delete $self->{notest};
7296 }
7297
7298 #-> sub CPAN::Distribution::unforce ;
7299 sub unforce {
7300   my($self) = @_;
7301   delete $self->{force_update};
7302 }
7303
7304 #-> sub CPAN::Distribution::isa_perl ;
7305 sub isa_perl {
7306   my($self) = @_;
7307   my $file = File::Basename::basename($self->id);
7308   if ($file =~ m{ ^ perl
7309                   -?
7310                   (5)
7311                   ([._-])
7312                   (
7313                    \d{3}(_[0-4][0-9])?
7314                    |
7315                    \d+\.\d+
7316                   )
7317                   \.tar[._-](?:gz|bz2)
7318                   (?!\n)\Z
7319                 }xs) {
7320     return "$1.$3";
7321   } elsif ($self->cpan_comment
7322            &&
7323            $self->cpan_comment =~ /isa_perl\(.+?\)/) {
7324     return $1;
7325   }
7326 }
7327
7328
7329 #-> sub CPAN::Distribution::perl ;
7330 sub perl {
7331     my ($self) = @_;
7332     if (! $self) {
7333         use Carp qw(carp);
7334         carp __PACKAGE__ . "::perl was called without parameters.";
7335     }
7336     return CPAN::HandleConfig->safe_quote($CPAN::Perl);
7337 }
7338
7339
7340 #-> sub CPAN::Distribution::make ;
7341 sub make {
7342     my($self) = @_;
7343     if (my $goto = $self->prefs->{goto}) {
7344         return $self->goto($goto);
7345     }
7346     my $make = $self->{modulebuild} ? "Build" : "make";
7347     # Emergency brake if they said install Pippi and get newest perl
7348     if ($self->isa_perl) {
7349         if (
7350             $self->called_for ne $self->id &&
7351             ! $self->{force_update}
7352         ) {
7353             # if we die here, we break bundles
7354             $CPAN::Frontend
7355                 ->mywarn(sprintf(
7356                             qq{The most recent version "%s" of the module "%s"
7357 is part of the perl-%s distribution. To install that, you need to run
7358   force install %s   --or--
7359   install %s
7360 },
7361                              $CPAN::META->instance(
7362                                                    'CPAN::Module',
7363                                                    $self->called_for
7364                                                   )->cpan_version,
7365                              $self->called_for,
7366                              $self->isa_perl,
7367                              $self->called_for,
7368                              $self->id,
7369                             ));
7370             $self->{make} = CPAN::Distrostatus->new("NO isa perl");
7371             $CPAN::Frontend->mysleep(1);
7372             return;
7373         }
7374     }
7375     $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
7376     $self->get;
7377     if ($self->{configure_requires_later}) {
7378         return;
7379     }
7380     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
7381                            ? $ENV{PERL5LIB}
7382                            : ($ENV{PERLLIB} || "");
7383     $CPAN::META->set_perl5lib;
7384     local $ENV{MAKEFLAGS}; # protect us from outer make calls
7385
7386     if ($CPAN::Signal) {
7387         delete $self->{force_update};
7388         return;
7389     }
7390
7391     my $builddir;
7392   EXCUSE: {
7393         my @e;
7394         if (!$self->{archived} || $self->{archived} eq "NO") {
7395             push @e, "Is neither a tar nor a zip archive.";
7396         }
7397
7398         if (!$self->{unwrapped}
7399             || (
7400                 UNIVERSAL::can($self->{unwrapped},"failed") ?
7401                 $self->{unwrapped}->failed :
7402                 $self->{unwrapped} =~ /^NO/
7403                )) {
7404             push @e, "Had problems unarchiving. Please build manually";
7405         }
7406
7407         unless ($self->{force_update}) {
7408             exists $self->{signature_verify} and
7409                 (
7410                  UNIVERSAL::can($self->{signature_verify},"failed") ?
7411                  $self->{signature_verify}->failed :
7412                  $self->{signature_verify} =~ /^NO/
7413                 )
7414                 and push @e, "Did not pass the signature test.";
7415         }
7416
7417         if (exists $self->{writemakefile} &&
7418             (
7419              UNIVERSAL::can($self->{writemakefile},"failed") ?
7420              $self->{writemakefile}->failed :
7421              $self->{writemakefile} =~ /^NO/
7422             )) {
7423             # XXX maybe a retry would be in order?
7424             my $err = UNIVERSAL::can($self->{writemakefile},"text") ?
7425                 $self->{writemakefile}->text :
7426                     $self->{writemakefile};
7427             $err =~ s/^NO\s*//;
7428             $err ||= "Had some problem writing Makefile";
7429             $err .= ", won't make";
7430             push @e, $err;
7431         }
7432
7433         if (defined $self->{make}) {
7434             if (UNIVERSAL::can($self->{make},"failed") ?
7435                 $self->{make}->failed :
7436                 $self->{make} =~ /^NO/) {
7437                 if ($self->{force_update}) {
7438                     # Trying an already failed 'make' (unless somebody else blocks)
7439                 } else {
7440                     # introduced for turning recursion detection into a distrostatus
7441                     my $error = length $self->{make}>3
7442                         ? substr($self->{make},3) : "Unknown error";
7443                     $CPAN::Frontend->mywarn("Could not make: $error\n");
7444                     $self->store_persistent_state;
7445                     return;
7446                 }
7447             } else {
7448                 push @e, "Has already been made";
7449             }
7450         }
7451
7452         my $later = $self->{later} || $self->{configure_requires_later};
7453         if ($later) { # see also undelay
7454             if ($later) {
7455                 push @e, $later;
7456             }
7457         }
7458
7459         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
7460         $builddir = $self->dir or
7461             $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
7462         unless (chdir $builddir) {
7463             push @e, "Couldn't chdir to '$builddir': $!";
7464         }
7465         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
7466     }
7467     if ($CPAN::Signal) {
7468         delete $self->{force_update};
7469         return;
7470     }
7471     $CPAN::Frontend->myprint("\n  CPAN.pm: Going to build ".$self->id."\n\n");
7472     $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
7473
7474     if ($^O eq 'MacOS') {
7475         Mac::BuildTools::make($self);
7476         return;
7477     }
7478
7479     my %env;
7480     while (my($k,$v) = each %ENV) {
7481         next unless defined $v;
7482         $env{$k} = $v;
7483     }
7484     local %ENV = %env;
7485     my $system;
7486     if (my $commandline = $self->prefs->{pl}{commandline}) {
7487         $system = $commandline;
7488         $ENV{PERL} = $^X;
7489     } elsif ($self->{'configure'}) {
7490         $system = $self->{'configure'};
7491     } elsif ($self->{modulebuild}) {
7492         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
7493         $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}";
7494     } else {
7495         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
7496         my $switch = "";
7497 # This needs a handler that can be turned on or off:
7498 #        $switch = "-MExtUtils::MakeMaker ".
7499 #            "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
7500 #            if $] > 5.00310;
7501         my $makepl_arg = $self->make_x_arg("pl");
7502         $ENV{PERL5_CPAN_IS_EXECUTING} = File::Spec->catfile($self->{build_dir},
7503                                                             "Makefile.PL");
7504         $system = sprintf("%s%s Makefile.PL%s",
7505                           $perl,
7506                           $switch ? " $switch" : "",
7507                           $makepl_arg ? " $makepl_arg" : "",
7508                          );
7509     }
7510     if (my $env = $self->prefs->{pl}{env}) {
7511         for my $e (keys %$env) {
7512             $ENV{$e} = $env->{$e};
7513         }
7514     }
7515     if (exists $self->{writemakefile}) {
7516     } else {
7517         local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
7518         my($ret,$pid,$output);
7519         $@ = "";
7520         my $go_via_alarm;
7521         if ($CPAN::Config->{inactivity_timeout}) {
7522             require Config;
7523             if ($Config::Config{d_alarm}
7524                 &&
7525                 $Config::Config{d_alarm} eq "define"
7526                ) {
7527                 $go_via_alarm++
7528             } else {
7529                 $CPAN::Frontend->mywarn("Warning: you have configured the config ".
7530                                         "variable 'inactivity_timeout' to ".
7531                                         "'$CPAN::Config->{inactivity_timeout}'. But ".
7532                                         "on this machine the system call 'alarm' ".
7533                                         "isn't available. This means that we cannot ".
7534                                         "provide the feature of intercepting long ".
7535                                         "waiting code and will turn this feature off.\n"
7536                                        );
7537                 $CPAN::Config->{inactivity_timeout} = 0;
7538             }
7539         }
7540         if ($go_via_alarm) {
7541             if ( $self->_should_report('pl') ) {
7542                 ($output, $ret) = CPAN::Reporter::record_command(
7543                     $system,
7544                     $CPAN::Config->{inactivity_timeout},
7545                 );
7546                 CPAN::Reporter::grade_PL( $self, $system, $output, $ret );
7547             }
7548             else {
7549                 eval {
7550                     alarm $CPAN::Config->{inactivity_timeout};
7551                     local $SIG{CHLD}; # = sub { wait };
7552                     if (defined($pid = fork)) {
7553                         if ($pid) { #parent
7554                             # wait;
7555                             waitpid $pid, 0;
7556                         } else {    #child
7557                             # note, this exec isn't necessary if
7558                             # inactivity_timeout is 0. On the Mac I'd
7559                             # suggest, we set it always to 0.
7560                             exec $system;
7561                         }
7562                     } else {
7563                         $CPAN::Frontend->myprint("Cannot fork: $!");
7564                         return;
7565                     }
7566                 };
7567                 alarm 0;
7568                 if ($@) {
7569                     kill 9, $pid;
7570                     waitpid $pid, 0;
7571                     my $err = "$@";
7572                     $CPAN::Frontend->myprint($err);
7573                     $self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
7574                     $@ = "";
7575                     $self->store_persistent_state;
7576                     return $self->goodbye("$system -- TIMED OUT");
7577                 }
7578             }
7579         } else {
7580             if (my $expect_model = $self->_prefs_with_expect("pl")) {
7581                 # XXX probably want to check _should_report here and warn
7582                 # about not being able to use CPAN::Reporter with expect
7583                 $ret = $self->_run_via_expect($system,$expect_model);
7584                 if (! defined $ret
7585                     && $self->{writemakefile}
7586                     && $self->{writemakefile}->failed) {
7587                     # timeout
7588                     return;
7589                 }
7590             }
7591             elsif ( $self->_should_report('pl') ) {
7592                 ($output, $ret) = CPAN::Reporter::record_command($system);
7593                 CPAN::Reporter::grade_PL( $self, $system, $output, $ret );
7594             }
7595             else {
7596                 $ret = system($system);
7597             }
7598             if ($ret != 0) {
7599                 $self->{writemakefile} = CPAN::Distrostatus
7600                     ->new("NO '$system' returned status $ret");
7601                 $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
7602                 $self->store_persistent_state;
7603                 return $self->goodbye("$system -- NOT OK");
7604             }
7605         }
7606         if (-f "Makefile" || -f "Build") {
7607             $self->{writemakefile} = CPAN::Distrostatus->new("YES");
7608             delete $self->{make_clean}; # if cleaned before, enable next
7609         } else {
7610             my $makefile = $self->{modulebuild} ? "Build" : "Makefile";
7611             $self->{writemakefile} = CPAN::Distrostatus
7612                 ->new(qq{NO -- No $makefile created});
7613             $self->store_persistent_state;
7614             return $self->goodbye("$system -- NO $makefile created");
7615         }
7616     }
7617     if ($CPAN::Signal) {
7618         delete $self->{force_update};
7619         return;
7620     }
7621     if (my @prereq = $self->unsat_prereq("later")) {
7622         if ($prereq[0][0] eq "perl") {
7623             my $need = "requires perl '$prereq[0][1]'";
7624             my $id = $self->pretty_id;
7625             $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
7626             $self->{make} = CPAN::Distrostatus->new("NO $need");
7627             $self->store_persistent_state;
7628             return $self->goodbye("[prereq] -- NOT OK");
7629         } else {
7630             my $follow = eval { $self->follow_prereqs("later",@prereq); };
7631             if (0) {
7632             } elsif ($follow) {
7633                 # signal success to the queuerunner
7634                 return 1;
7635             } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
7636                 $CPAN::Frontend->mywarn($@);
7637                 return $self->goodbye("[depend] -- NOT OK");
7638             }
7639         }
7640     }
7641     if ($CPAN::Signal) {
7642         delete $self->{force_update};
7643         return;
7644     }
7645     if (my $commandline = $self->prefs->{make}{commandline}) {
7646         $system = $commandline;
7647         $ENV{PERL} = CPAN::find_perl;
7648     } else {
7649         if ($self->{modulebuild}) {
7650             unless (-f "Build") {
7651                 my $cwd = CPAN::anycwd();
7652                 $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
7653                                         " in cwd[$cwd]. Danger, Will Robinson!\n");
7654                 $CPAN::Frontend->mysleep(5);
7655             }
7656             $system = join " ", $self->_build_command(), $CPAN::Config->{mbuild_arg};
7657         } else {
7658             $system = join " ", $self->_make_command(),  $CPAN::Config->{make_arg};
7659         }
7660         $system =~ s/\s+$//;
7661         my $make_arg = $self->make_x_arg("make");
7662         $system = sprintf("%s%s",
7663                           $system,
7664                           $make_arg ? " $make_arg" : "",
7665                          );
7666     }
7667     if (my $env = $self->prefs->{make}{env}) { # overriding the local
7668                                                # ENV of PL, not the
7669                                                # outer ENV, but
7670                                                # unlikely to be a risk
7671         for my $e (keys %$env) {
7672             $ENV{$e} = $env->{$e};
7673         }
7674     }
7675     my $expect_model = $self->_prefs_with_expect("make");
7676     my $want_expect = 0;
7677     if ( $expect_model && @{$expect_model->{talk}} ) {
7678         my $can_expect = $CPAN::META->has_inst("Expect");
7679         if ($can_expect) {
7680             $want_expect = 1;
7681         } else {
7682             $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
7683                                     "system()\n");
7684         }
7685     }
7686     my $system_ok;
7687     if ($want_expect) {
7688         # XXX probably want to check _should_report here and
7689         # warn about not being able to use CPAN::Reporter with expect
7690         $system_ok = $self->_run_via_expect($system,$expect_model) == 0;
7691     }
7692     elsif ( $self->_should_report('make') ) {
7693         my ($output, $ret) = CPAN::Reporter::record_command($system);
7694         CPAN::Reporter::grade_make( $self, $system, $output, $ret );
7695         $system_ok = ! $ret;
7696     }
7697     else {
7698         $system_ok = system($system) == 0;
7699     }
7700     $self->introduce_myself;
7701     if ( $system_ok ) {
7702         $CPAN::Frontend->myprint("  $system -- OK\n");
7703         $self->{make} = CPAN::Distrostatus->new("YES");
7704     } else {
7705         $self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
7706         $self->{make} = CPAN::Distrostatus->new("NO");
7707         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
7708     }
7709     $self->store_persistent_state;
7710 }
7711
7712 # CPAN::Distribution::goodbye ;
7713 sub goodbye {
7714     my($self,$goodbye) = @_;
7715     my $id = $self->pretty_id;
7716     $CPAN::Frontend->mywarn("  $id\n  $goodbye\n");
7717     return;
7718 }
7719
7720 # CPAN::Distribution::_run_via_expect ;
7721 sub _run_via_expect {
7722     my($self,$system,$expect_model) = @_;
7723     CPAN->debug("system[$system]expect_model[$expect_model]") if $CPAN::DEBUG;
7724     if ($CPAN::META->has_inst("Expect")) {
7725         my $expo = Expect->new;  # expo Expect object;
7726         $expo->spawn($system);
7727         $expect_model->{mode} ||= "deterministic";
7728         if ($expect_model->{mode} eq "deterministic") {
7729             return $self->_run_via_expect_deterministic($expo,$expect_model);
7730         } elsif ($expect_model->{mode} eq "anyorder") {
7731             return $self->_run_via_expect_anyorder($expo,$expect_model);
7732         } else {
7733             die "Panic: Illegal expect mode: $expect_model->{mode}";
7734         }
7735     } else {
7736         $CPAN::Frontend->mywarn("Expect not installed, falling back to system()\n");
7737         return system($system);
7738     }
7739 }
7740
7741 sub _run_via_expect_anyorder {
7742     my($self,$expo,$expect_model) = @_;
7743     my $timeout = $expect_model->{timeout} || 5;
7744     my $reuse = $expect_model->{reuse};
7745     my @expectacopy = @{$expect_model->{talk}}; # we trash it!
7746     my $but = "";
7747   EXPECT: while () {
7748         my($eof,$ran_into_timeout);
7749         my @match = $expo->expect($timeout,
7750                                   [ eof => sub {
7751                                         $eof++;
7752                                     } ],
7753                                   [ timeout => sub {
7754                                         $ran_into_timeout++;
7755                                     } ],
7756                                   -re => eval"qr{.}",
7757                                  );
7758         if ($match[2]) {
7759             $but .= $match[2];
7760         }
7761         $but .= $expo->clear_accum;
7762         if ($eof) {
7763             $expo->soft_close;
7764             return $expo->exitstatus();
7765         } elsif ($ran_into_timeout) {
7766             # warn "DEBUG: they are asking a question, but[$but]";
7767             for (my $i = 0; $i <= $#expectacopy; $i+=2) {
7768                 my($next,$send) = @expectacopy[$i,$i+1];
7769                 my $regex = eval "qr{$next}";
7770                 # warn "DEBUG: will compare with regex[$regex].";
7771                 if ($but =~ /$regex/) {
7772                     # warn "DEBUG: will send send[$send]";
7773                     $expo->send($send);
7774                     # never allow reusing an QA pair unless they told us
7775                     splice @expectacopy, $i, 2 unless $reuse;
7776                     next EXPECT;
7777                 }
7778             }
7779             my $why = "could not answer a question during the dialog";
7780             $CPAN::Frontend->mywarn("Failing: $why\n");
7781             $self->{writemakefile} =
7782                 CPAN::Distrostatus->new("NO $why");
7783             return;
7784         }
7785     }
7786 }
7787
7788 sub _run_via_expect_deterministic {
7789     my($self,$expo,$expect_model) = @_;
7790     my $ran_into_timeout;
7791     my $timeout = $expect_model->{timeout} || 15; # currently unsettable
7792     my $expecta = $expect_model->{talk};
7793   EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) {
7794         my($re,$send) = @$expecta[$i,$i+1];
7795         CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG;
7796         my $regex = eval "qr{$re}";
7797         $expo->expect($timeout,
7798                       [ eof => sub {
7799                             my $but = $expo->clear_accum;
7800                             $CPAN::Frontend->mywarn("EOF (maybe harmless)
7801 expected[$regex]\nbut[$but]\n\n");
7802                             last EXPECT;
7803                         } ],
7804                       [ timeout => sub {
7805                             my $but = $expo->clear_accum;
7806                             $CPAN::Frontend->mywarn("TIMEOUT
7807 expected[$regex]\nbut[$but]\n\n");
7808                             $ran_into_timeout++;
7809                         } ],
7810                       -re => $regex);
7811         if ($ran_into_timeout) {
7812             # note that the caller expects 0 for success
7813             $self->{writemakefile} =
7814                 CPAN::Distrostatus->new("NO timeout during expect dialog");
7815             return;
7816         }
7817         $expo->send($send);
7818     }
7819     $expo->soft_close;
7820     return $expo->exitstatus();
7821 }
7822
7823 #-> CPAN::Distribution::_validate_distropref
7824 sub _validate_distropref {
7825     my($self,@args) = @_;
7826     if (
7827         $CPAN::META->has_inst("CPAN::Kwalify")
7828         &&
7829         $CPAN::META->has_inst("Kwalify")
7830        ) {
7831         eval {CPAN::Kwalify::_validate("distroprefs",@args);};
7832         if ($@) {
7833             $CPAN::Frontend->mywarn($@);
7834         }
7835     } else {
7836         CPAN->debug("not validating '@args'") if $CPAN::DEBUG;
7837     }
7838 }
7839
7840 #-> CPAN::Distribution::_find_prefs
7841 sub _find_prefs {
7842     my($self) = @_;
7843     my $distroid = $self->pretty_id;
7844     #CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG;
7845     my $prefs_dir = $CPAN::Config->{prefs_dir};
7846     return if $prefs_dir =~ /^\s*$/;
7847     eval { File::Path::mkpath($prefs_dir); };
7848     if ($@) {
7849         $CPAN::Frontend->mydie("Cannot create directory $prefs_dir");
7850     }
7851     my $yaml_module = CPAN::_yaml_module;
7852     my @extensions;
7853     if ($CPAN::META->has_inst($yaml_module)) {
7854         push @extensions, "yml";
7855     } else {
7856         my @fallbacks;
7857         if ($CPAN::META->has_inst("Data::Dumper")) {
7858             push @extensions, "dd";
7859             push @fallbacks, "Data::Dumper";
7860         }
7861         if ($CPAN::META->has_inst("Storable")) {
7862             push @extensions, "st";
7863             push @fallbacks, "Storable";
7864         }
7865         if (@fallbacks) {
7866             local $" = " and ";
7867             unless ($self->{have_complained_about_missing_yaml}++) {
7868                 $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back ".
7869                                         "to @fallbacks to read prefs '$prefs_dir'\n");
7870             }
7871         } else {
7872             unless ($self->{have_complained_about_missing_yaml}++) {
7873                 $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot ".
7874                                         "read prefs '$prefs_dir'\n");
7875             }
7876         }
7877     }
7878     if (@extensions) {
7879         my $dh = DirHandle->new($prefs_dir)
7880             or die Carp::croak("Couldn't open '$prefs_dir': $!");
7881       DIRENT: for (sort $dh->read) {
7882             next if $_ eq "." || $_ eq "..";
7883             my $exte = join "|", @extensions;
7884             next unless /\.($exte)$/;
7885             my $thisexte = $1;
7886             my $abs = File::Spec->catfile($prefs_dir, $_);
7887             if (-f $abs) {
7888                 #CPAN->debug(sprintf "abs[%s]", $abs) if $CPAN::DEBUG;
7889                 my @distropref;
7890                 if ($thisexte eq "yml") {
7891                     # need no eval because if we have no YAML we do not try to read *.yml
7892                     #CPAN->debug(sprintf "before yaml load abs[%s]", $abs) if $CPAN::DEBUG;
7893                     @distropref = @{CPAN->_yaml_loadfile($abs)};
7894                     #CPAN->debug(sprintf "after yaml load abs[%s]", $abs) if $CPAN::DEBUG;
7895                 } elsif ($thisexte eq "dd") {
7896                     package CPAN::Eval;
7897                     no strict;
7898                     open FH, "<$abs" or $CPAN::Frontend->mydie("Could not open '$abs': $!");
7899                     local $/;
7900                     my $eval = <FH>;
7901                     close FH;
7902                     eval $eval;
7903                     if ($@) {
7904                         $CPAN::Frontend->mydie("Error in distroprefs file $_\: $@");
7905                     }
7906                     my $i = 1;
7907                     while (${"VAR".$i}) {
7908                         push @distropref, ${"VAR".$i};
7909                         $i++;
7910                     }
7911                 } elsif ($thisexte eq "st") {
7912                     # eval because Storable is never forward compatible
7913                     eval { @distropref = @{scalar Storable::retrieve($abs)}; };
7914                     if ($@) {
7915                         $CPAN::Frontend->mywarn("Error reading distroprefs file ".
7916                                                 "$_, skipping\: $@");
7917                         $CPAN::Frontend->mysleep(4);
7918                         next DIRENT;
7919                     }
7920                 }
7921                 # $DB::single=1;
7922                 #CPAN->debug(sprintf "#distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
7923               ELEMENT: for my $y (0..$#distropref) {
7924                     my $distropref = $distropref[$y];
7925                     $self->_validate_distropref($distropref,$abs,$y);
7926                     my $match = $distropref->{match};
7927                     unless ($match) {
7928                         #CPAN->debug("no 'match' in abs[$abs], skipping") if $CPAN::DEBUG;
7929                         next ELEMENT;
7930                     }
7931                     my $ok = 1;
7932                     # do not take the order of C<keys %$match> because
7933                     # "module" is by far the slowest
7934                     my $saw_valid_subkeys = 0;
7935                     for my $sub_attribute (qw(distribution perl perlconfig module)) {
7936                         next unless exists $match->{$sub_attribute};
7937                         $saw_valid_subkeys++;
7938                         my $qr = eval "qr{$distropref->{match}{$sub_attribute}}";
7939                         if ($sub_attribute eq "module") {
7940                             my $okm = 0;
7941                             #CPAN->debug(sprintf "distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
7942                             my @modules = $self->containsmods;
7943                             #CPAN->debug(sprintf "modules[%s]", join(",",@modules)) if $CPAN::DEBUG;
7944                           MODULE: for my $module (@modules) {
7945                                 $okm ||= $module =~ /$qr/;
7946                                 last MODULE if $okm;
7947                             }
7948                             $ok &&= $okm;
7949                         } elsif ($sub_attribute eq "distribution") {
7950                             my $okd = $distroid =~ /$qr/;
7951                             $ok &&= $okd;
7952                         } elsif ($sub_attribute eq "perl") {
7953                             my $okp = CPAN::find_perl =~ /$qr/;
7954                             $ok &&= $okp;
7955                         } elsif ($sub_attribute eq "perlconfig") {
7956                             for my $perlconfigkey (keys %{$match->{perlconfig}}) {
7957                                 my $perlconfigval = $match->{perlconfig}->{$perlconfigkey};
7958                                 # XXX should probably warn if Config does not exist
7959                                 my $okpc = $Config::Config{$perlconfigkey} =~ /$perlconfigval/;
7960                                 $ok &&= $okpc;
7961                                 last if $ok == 0;
7962                             }
7963                         } else {
7964                             $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ".
7965                                                    "unknown sub_attribut '$sub_attribute'. ".
7966                                                    "Please ".
7967                                                    "remove, cannot continue.");
7968                         }
7969                         last if $ok == 0; # short circuit
7970                     }
7971                     unless ($saw_valid_subkeys) {
7972                         $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ".
7973                                                "missing match/* subattribute. ".
7974                                                "Please ".
7975                                                "remove, cannot continue.");
7976                     }
7977                     #CPAN->debug(sprintf "ok[%d]", $ok) if $CPAN::DEBUG;
7978                     if ($ok) {
7979                         return {
7980                                 prefs => $distropref,
7981                                 prefs_file => $abs,
7982                                 prefs_file_doc => $y,
7983                                };
7984                     }
7985
7986                 }
7987             }
7988         }
7989         $dh->close;
7990     }
7991     return;
7992 }
7993
7994 # CPAN::Distribution::prefs
7995 sub prefs {
7996     my($self) = @_;
7997     if (exists $self->{negative_prefs_cache}
7998         &&
7999         $self->{negative_prefs_cache} != $CPAN::CurrentCommandId
8000        ) {
8001         delete $self->{negative_prefs_cache};
8002         delete $self->{prefs};
8003     }
8004     if (exists $self->{prefs}) {
8005         return $self->{prefs}; # XXX comment out during debugging
8006     }
8007     if ($CPAN::Config->{prefs_dir}) {
8008         CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG;
8009         my $prefs = $self->_find_prefs();
8010         $prefs ||= ""; # avoid warning next line
8011         CPAN->debug("prefs[$prefs]") if $CPAN::DEBUG;
8012         if ($prefs) {
8013             for my $x (qw(prefs prefs_file prefs_file_doc)) {
8014                 $self->{$x} = $prefs->{$x};
8015             }
8016             my $bs = sprintf(
8017                              "%s[%s]",
8018                              File::Basename::basename($self->{prefs_file}),
8019                              $self->{prefs_file_doc},
8020                             );
8021             my $filler1 = "_" x 22;
8022             my $filler2 = int(66 - length($bs))/2;
8023             $filler2 = 0 if $filler2 < 0;
8024             $filler2 = " " x $filler2;
8025             $CPAN::Frontend->myprint("
8026 $filler1 D i s t r o P r e f s $filler1
8027 $filler2 $bs $filler2
8028 ");
8029             $CPAN::Frontend->mysleep(1);
8030             return $self->{prefs};
8031         }
8032     }
8033     $self->{negative_prefs_cache} = $CPAN::CurrentCommandId;
8034     return $self->{prefs} = +{};
8035 }
8036
8037 # CPAN::Distribution::make_x_arg
8038 sub make_x_arg {
8039     my($self, $whixh) = @_;
8040     my $make_x_arg;
8041     my $prefs = $self->prefs;
8042     if (
8043         $prefs
8044         && exists $prefs->{$whixh}
8045         && exists $prefs->{$whixh}{args}
8046         && $prefs->{$whixh}{args}
8047        ) {
8048         $make_x_arg = join(" ",
8049                            map {CPAN::HandleConfig
8050                                  ->safe_quote($_)} @{$prefs->{$whixh}{args}},
8051                           );
8052     }
8053     my $what = sprintf "make%s_arg", $whixh eq "make" ? "" : $whixh;
8054     $make_x_arg ||= $CPAN::Config->{$what};
8055     return $make_x_arg;
8056 }
8057
8058 # CPAN::Distribution::_make_command
8059 sub _make_command {
8060     my ($self) = @_;
8061     if ($self) {
8062         return
8063             CPAN::HandleConfig
8064                 ->safe_quote(
8065                              CPAN::HandleConfig->prefs_lookup($self,
8066                                                               q{make})
8067                              || $Config::Config{make}
8068                              || 'make'
8069                             );
8070     } else {
8071         # Old style call, without object. Deprecated
8072         Carp::confess("CPAN::_make_command() used as function. Don't Do That.");
8073         return
8074           safe_quote(undef,
8075                      CPAN::HandleConfig->prefs_lookup($self,q{make})
8076                      || $CPAN::Config->{make}
8077                      || $Config::Config{make}
8078                      || 'make');
8079     }
8080 }
8081
8082 #-> sub CPAN::Distribution::follow_prereqs ;
8083 sub follow_prereqs {
8084     my($self) = shift;
8085     my($slot) = shift;
8086     my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
8087     return unless @prereq_tuples;
8088     my @prereq = map { $_->[0] } @prereq_tuples;
8089     my $pretty_id = $self->pretty_id;
8090     my %map = (
8091                b => "build_requires",
8092                r => "requires",
8093                c => "commandline",
8094               );
8095     my($filler1,$filler2,$filler3,$filler4);
8096     # $DB::single=1;
8097     my $unsat = "Unsatisfied dependencies detected during";
8098     my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id);
8099     {
8100         my $r = int(($w - length($unsat))/2);
8101         my $l = $w - length($unsat) - $r;
8102         $filler1 = "-"x4 . " "x$l;
8103         $filler2 = " "x$r . "-"x4 . "\n";
8104     }
8105     {
8106         my $r = int(($w - length($pretty_id))/2);
8107         my $l = $w - length($pretty_id) - $r;
8108         $filler3 = "-"x4 . " "x$l;
8109         $filler4 = " "x$r . "-"x4 . "\n";
8110     }
8111     $CPAN::Frontend->
8112         myprint("$filler1 $unsat $filler2".
8113                 "$filler3 $pretty_id $filler4".
8114                 join("", map {"    $_->[0] \[$map{$_->[1]}]\n"} @prereq_tuples),
8115                );
8116     my $follow = 0;
8117     if ($CPAN::Config->{prerequisites_policy} eq "follow") {
8118         $follow = 1;
8119     } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
8120         my $answer = CPAN::Shell::colorable_makemaker_prompt(
8121 "Shall I follow them and prepend them to the queue
8122 of modules we are processing right now?", "yes");
8123         $follow = $answer =~ /^\s*y/i;
8124     } else {
8125         local($") = ", ";
8126         $CPAN::Frontend->
8127             myprint("  Ignoring dependencies on modules @prereq\n");
8128     }
8129     if ($follow) {
8130         my $id = $self->id;
8131         # color them as dirty
8132         for my $p (@prereq) {
8133             # warn "calling color_cmd_tmps(0,1)";
8134             my $any = CPAN::Shell->expandany($p);
8135             $self->{$slot . "_for"}{$any->id}++;
8136             if ($any) {
8137                 $any->color_cmd_tmps(0,2);
8138             } else {
8139                 $CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$p'\n");
8140                 $CPAN::Frontend->mysleep(2);
8141             }
8142         }
8143         # queue them and re-queue yourself
8144         CPAN::Queue->jumpqueue({qmod => $id, reqtype => $self->{reqtype}},
8145                                map {+{qmod=>$_->[0],reqtype=>$_->[1]}} reverse @prereq_tuples);
8146         $self->{$slot} = "Delayed until after prerequisites";
8147         return 1; # signal success to the queuerunner
8148     }
8149     return;
8150 }
8151
8152 #-> sub CPAN::Distribution::unsat_prereq ;
8153 # return ([Foo=>1],[Bar=>1.2]) for normal modules
8154 # return ([perl=>5.008]) if we need a newer perl than we are running under
8155 sub unsat_prereq {
8156     my($self,$slot) = @_;
8157     my(%merged,$prereq_pm);
8158     my $prefs_depends = $self->prefs->{depends}||{};
8159     if ($slot eq "configure_requires_later") {
8160         my $meta_yml = $self->parse_meta_yml();
8161         %merged = (%{$meta_yml->{configure_requires}||{}},
8162                    %{$prefs_depends->{configure_requires}||{}});
8163         $prereq_pm = {}; # configure_requires defined as "b"
8164     } elsif ($slot eq "later") {
8165         my $prereq_pm_0 = $self->prereq_pm || {};
8166         for my $reqtype (qw(requires build_requires)) {
8167             $prereq_pm->{$reqtype} = {%{$prereq_pm_0->{$reqtype}||{}}}; # copy to not pollute it
8168             for my $k (keys %{$prefs_depends->{$reqtype}||{}}) {
8169                 $prereq_pm->{$reqtype}{$k} = $prefs_depends->{$reqtype}{$k};
8170             }
8171         }
8172         %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}});
8173     } else {
8174         die "Panic: illegal slot '$slot'";
8175     }
8176     my(@need);
8177     my @merged = %merged;
8178     CPAN->debug("all merged_prereqs[@merged]") if $CPAN::DEBUG;
8179   NEED: while (my($need_module, $need_version) = each %merged) {
8180         my($available_version,$available_file,$nmo);
8181         if ($need_module eq "perl") {
8182             $available_version = $];
8183             $available_file = CPAN::find_perl;
8184         } else {
8185             $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
8186             next if $nmo->uptodate;
8187             $available_file = $nmo->available_file;
8188
8189             # if they have not specified a version, we accept any installed one
8190             if (defined $available_file
8191                 and ( # a few quick shortcurcuits
8192                      not defined $need_version
8193                      or $need_version eq '0'    # "==" would trigger warning when not numeric
8194                      or $need_version eq "undef"
8195                     )) {
8196                 next NEED;
8197             }
8198
8199             $available_version = $nmo->available_version;
8200         }
8201
8202         # We only want to install prereqs if either they're not installed
8203         # or if the installed version is too old. We cannot omit this
8204         # check, because if 'force' is in effect, nobody else will check.
8205         if (defined $available_file) {
8206             my(@all_requirements) = split /\s*,\s*/, $need_version;
8207             local($^W) = 0;
8208             my $ok = 0;
8209           RQ: for my $rq (@all_requirements) {
8210                 if ($rq =~ s|>=\s*||) {
8211                 } elsif ($rq =~ s|>\s*||) {
8212                     # 2005-12: one user
8213                     if (CPAN::Version->vgt($available_version,$rq)) {
8214                         $ok++;
8215                     }
8216                     next RQ;
8217                 } elsif ($rq =~ s|!=\s*||) {
8218                     # 2005-12: no user
8219                     if (CPAN::Version->vcmp($available_version,$rq)) {
8220                         $ok++;
8221                         next RQ;
8222                     } else {
8223                         last RQ;
8224                     }
8225                 } elsif ($rq =~ m|<=?\s*|) {
8226                     # 2005-12: no user
8227                     $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n");
8228                     $ok++;
8229                     next RQ;
8230                 }
8231                 if (! CPAN::Version->vgt($rq, $available_version)) {
8232                     $ok++;
8233                 }
8234                 CPAN->debug(sprintf("need_module[%s]available_file[%s]".
8235                                     "available_version[%s]rq[%s]ok[%d]",
8236                                     $need_module,
8237                                     $available_file,
8238                                     $available_version,
8239                                     CPAN::Version->readable($rq),
8240                                     $ok,
8241                                    )) if $CPAN::DEBUG;
8242             }
8243             next NEED if $ok == @all_requirements;
8244         }
8245
8246         if ($need_module eq "perl") {
8247             return ["perl", $need_version];
8248         }
8249         $self->{sponsored_mods}{$need_module} ||= 0;
8250         CPAN->debug("need_module[$need_module]s/s/n[$self->{sponsored_mods}{$need_module}]") if $CPAN::DEBUG;
8251         if ($self->{sponsored_mods}{$need_module}++) {
8252             # We have already sponsored it and for some reason it's still
8253             # not available. So we do ... what??
8254
8255             # if we push it again, we have a potential infinite loop
8256
8257             # The following "next" was a very problematic construct.
8258             # It helped a lot but broke some day and had to be
8259             # replaced.
8260
8261             # We must be able to deal with modules that come again and
8262             # again as a prereq and have themselves prereqs and the
8263             # queue becomes long but finally we would find the correct
8264             # order. The RecursiveDependency check should trigger a
8265             # die when it's becoming too weird. Unfortunately removing
8266             # this next breaks many other things.
8267
8268             # The bug that brought this up is described in Todo under
8269             # "5.8.9 cannot install Compress::Zlib"
8270
8271             # next; # this is the next that had to go away
8272
8273             # The following "next NEED" are fine and the error message
8274             # explains well what is going on. For example when the DBI
8275             # fails and consequently DBD::SQLite fails and now we are
8276             # processing CPAN::SQLite. Then we must have a "next" for
8277             # DBD::SQLite. How can we get it and how can we identify
8278             # all other cases we must identify?
8279
8280             my $do = $nmo->distribution;
8281             next NEED unless $do; # not on CPAN
8282             if (CPAN::Version->vcmp($need_version, $nmo->ro->{CPAN_VERSION}) > 0){
8283                 $CPAN::Frontend->mywarn("Warning: Prerequisite ".
8284                                         "'$need_module => $need_version' ".
8285                                         "for '$self->{ID}' seems ".
8286                                         "not available according to the indexes\n"
8287                                        );
8288                 next NEED;
8289             }
8290           NOSAYER: for my $nosayer (
8291                                     "unwrapped",
8292                                     "writemakefile",
8293                                     "signature_verify",
8294                                     "make",
8295                                     "make_test",
8296                                     "install",
8297                                     "make_clean",
8298                                    ) {
8299                 if ($do->{$nosayer}) {
8300                     if (UNIVERSAL::can($do->{$nosayer},"failed") ?
8301                         $do->{$nosayer}->failed :
8302                         $do->{$nosayer} =~ /^NO/) {
8303                         if ($nosayer eq "make_test"
8304                             &&
8305                             $do->{make_test}{COMMANDID} != $CPAN::CurrentCommandId
8306                            ) {
8307                             next NOSAYER;
8308                         }
8309                         $CPAN::Frontend->mywarn("Warning: Prerequisite ".
8310                                                 "'$need_module => $need_version' ".
8311                                                 "for '$self->{ID}' failed when ".
8312                                                 "processing '$do->{ID}' with ".
8313                                                 "'$nosayer => $do->{$nosayer}'. Continuing, ".
8314                                                 "but chances to succeed are limited.\n"
8315                                                );
8316                         next NEED;
8317                     } else { # the other guy succeeded
8318                         if ($nosayer eq "install") {
8319                             # we had this with
8320                             # DMAKI/DateTime-Calendar-Chinese-0.05.tar.gz
8321                             # 2007-03
8322                             $CPAN::Frontend->mywarn("Warning: Prerequisite ".
8323                                                     "'$need_module => $need_version' ".
8324                                                     "for '$self->{ID}' already installed ".
8325                                                     "but installation looks suspicious. ".
8326                                                     "Skipping another installation attempt, ".
8327                                                     "to prevent looping endlessly.\n"
8328                                                    );
8329                             next NEED;
8330                         }
8331                     }
8332                 }
8333             }
8334         }
8335         my $needed_as = exists $prereq_pm->{requires}{$need_module} ? "r" : "b";
8336         push @need, [$need_module,$needed_as];
8337     }
8338     my @unfolded = map { "[".join(",",@$_)."]" } @need;
8339     CPAN->debug("returning from unsat_prereq[@unfolded]") if $CPAN::DEBUG;
8340     @need;
8341 }
8342
8343 #-> sub CPAN::Distribution::read_yaml ;
8344 sub read_yaml {
8345     my($self) = @_;
8346     return $self->{yaml_content} if exists $self->{yaml_content};
8347     my $build_dir = $self->{build_dir};
8348     my $yaml = File::Spec->catfile($build_dir,"META.yml");
8349     $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
8350     return unless -f $yaml;
8351     eval { $self->{yaml_content} = CPAN->_yaml_loadfile($yaml)->[0]; };
8352     if ($@) {
8353         $CPAN::Frontend->mywarn("Could not read ".
8354                                 "'$yaml'. Falling back to other ".
8355                                 "methods to determine prerequisites\n");
8356         return $self->{yaml_content} = undef; # if we die, then we
8357                                               # cannot read YAML's own
8358                                               # META.yml
8359     }
8360     # not "authoritative"
8361     if (not exists $self->{yaml_content}{dynamic_config}
8362         or $self->{yaml_content}{dynamic_config}
8363        ) {
8364         $self->{yaml_content} = undef;
8365     }
8366     $self->debug(sprintf "yaml_content[%s]", $self->{yaml_content} || "UNDEF")
8367         if $CPAN::DEBUG;
8368     return $self->{yaml_content};
8369 }
8370
8371 #-> sub CPAN::Distribution::prereq_pm ;
8372 sub prereq_pm {
8373     my($self) = @_;
8374     $self->{prereq_pm_detected} ||= 0;
8375     CPAN->debug("ID[$self->{ID}]prereq_pm_detected[$self->{prereq_pm_detected}]") if $CPAN::DEBUG;
8376     return $self->{prereq_pm} if $self->{prereq_pm_detected};
8377     return unless $self->{writemakefile}  # no need to have succeeded
8378                                           # but we must have run it
8379         || $self->{modulebuild};
8380     CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
8381                 $self->{writemakefile}||"",
8382                 $self->{modulebuild}||"",
8383                ) if $CPAN::DEBUG;
8384     my($req,$breq);
8385     if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
8386         $req =  $yaml->{requires} || {};
8387         $breq =  $yaml->{build_requires} || {};
8388         undef $req unless ref $req eq "HASH" && %$req;
8389         if ($req) {
8390             if ($yaml->{generated_by} &&
8391                 $yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
8392                 my $eummv = do { local $^W = 0; $1+0; };
8393                 if ($eummv < 6.2501) {
8394                     # thanks to Slaven for digging that out: MM before
8395                     # that could be wrong because it could reflect a
8396                     # previous release
8397                     undef $req;
8398                 }
8399             }
8400             my $areq;
8401             my $do_replace;
8402             while (my($k,$v) = each %{$req||{}}) {
8403                 if ($v =~ /\d/) {
8404                     $areq->{$k} = $v;
8405                 } elsif ($k =~ /[A-Za-z]/ &&
8406                          $v =~ /[A-Za-z]/ &&
8407                          $CPAN::META->exists("Module",$v)
8408                         ) {
8409                     $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
8410                                             "requires hash: $k => $v; I'll take both ".
8411                                             "key and value as a module name\n");
8412                     $CPAN::Frontend->mysleep(1);
8413                     $areq->{$k} = 0;
8414                     $areq->{$v} = 0;
8415                     $do_replace++;
8416                 }
8417             }
8418             $req = $areq if $do_replace;
8419         }
8420     }
8421     unless ($req || $breq) {
8422         my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
8423         my $makefile = File::Spec->catfile($build_dir,"Makefile");
8424         my $fh;
8425         if (-f $makefile
8426             and
8427             $fh = FileHandle->new("<$makefile\0")) {
8428             CPAN->debug("Getting prereq from Makefile") if $CPAN::DEBUG;
8429             local($/) = "\n";
8430             while (<$fh>) {
8431                 last if /MakeMaker post_initialize section/;
8432                 my($p) = m{^[\#]
8433                            \s+PREREQ_PM\s+=>\s+(.+)
8434                        }x;
8435                 next unless $p;
8436                 # warn "Found prereq expr[$p]";
8437
8438                 #  Regexp modified by A.Speer to remember actual version of file
8439                 #  PREREQ_PM hash key wants, then add to
8440                 while ( $p =~ m/(?:\s)([\w\:]+)=>(q\[.*?\]|undef),?/g ) {
8441                     # In case a prereq is mentioned twice, complain.
8442                     if ( defined $req->{$1} ) {
8443                         warn "Warning: PREREQ_PM mentions $1 more than once, ".
8444                             "last mention wins";
8445                     }
8446                     my($m,$n) = ($1,$2);
8447                     if ($n =~ /^q\[(.*?)\]$/) {
8448                         $n = $1;
8449                     }
8450                     $req->{$m} = $n;
8451                 }
8452                 last;
8453             }
8454         }
8455     }
8456     unless ($req || $breq) {
8457         my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
8458         my $buildfile = File::Spec->catfile($build_dir,"Build");
8459         if (-f $buildfile) {
8460             CPAN->debug("Found '$buildfile'") if $CPAN::DEBUG;
8461             my $build_prereqs = File::Spec->catfile($build_dir,"_build","prereqs");
8462             if (-f $build_prereqs) {
8463                 CPAN->debug("Getting prerequisites from '$build_prereqs'") if $CPAN::DEBUG;
8464                 my $content = do { local *FH;
8465                                    open FH, $build_prereqs
8466                                        or $CPAN::Frontend->mydie("Could not open ".
8467                                                                  "'$build_prereqs': $!");
8468                                    local $/;
8469                                    <FH>;
8470                                };
8471                 my $bphash = eval $content;
8472                 if ($@) {
8473                 } else {
8474                     $req  = $bphash->{requires} || +{};
8475                     $breq = $bphash->{build_requires} || +{};
8476                 }
8477             }
8478         }
8479     }
8480     if (-f "Build.PL"
8481         && ! -f "Makefile.PL"
8482         && ! exists $req->{"Module::Build"}
8483         && ! $CPAN::META->has_inst("Module::Build")) {
8484         $CPAN::Frontend->mywarn("  Warning: CPAN.pm discovered Module::Build as ".
8485                                 "undeclared prerequisite.\n".
8486                                 "  Adding it now as such.\n"
8487                                );
8488         $CPAN::Frontend->mysleep(5);
8489         $req->{"Module::Build"} = 0;
8490         delete $self->{writemakefile};
8491     }
8492     if ($req || $breq) {
8493         $self->{prereq_pm_detected}++;
8494         return $self->{prereq_pm} = { requires => $req, build_requires => $breq };
8495     }
8496 }
8497
8498 #-> sub CPAN::Distribution::test ;
8499 sub test {
8500     my($self) = @_;
8501     if (my $goto = $self->prefs->{goto}) {
8502         return $self->goto($goto);
8503     }
8504     $self->make;
8505     if ($CPAN::Signal) {
8506       delete $self->{force_update};
8507       return;
8508     }
8509     # warn "XDEBUG: checking for notest: $self->{notest} $self";
8510     if ($self->{notest}) {
8511         $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
8512         return 1;
8513     }
8514
8515     my $make = $self->{modulebuild} ? "Build" : "make";
8516
8517     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
8518                            ? $ENV{PERL5LIB}
8519                            : ($ENV{PERLLIB} || "");
8520
8521     $CPAN::META->set_perl5lib;
8522     local $ENV{MAKEFLAGS}; # protect us from outer make calls
8523
8524     $CPAN::Frontend->myprint("Running $make test\n");
8525
8526   EXCUSE: {
8527         my @e;
8528         if ($self->{make} or $self->{later}) {
8529             # go ahead
8530         } else {
8531             push @e,
8532                 "Make had some problems, won't test";
8533         }
8534
8535         exists $self->{make} and
8536             (
8537              UNIVERSAL::can($self->{make},"failed") ?
8538              $self->{make}->failed :
8539              $self->{make} =~ /^NO/
8540             ) and push @e, "Can't test without successful make";
8541         $self->{badtestcnt} ||= 0;
8542         if ($self->{badtestcnt} > 0) {
8543             require Data::Dumper;
8544             CPAN->debug(sprintf "NOREPEAT[%s]", Data::Dumper::Dumper($self)) if $CPAN::DEBUG;
8545             push @e, "Won't repeat unsuccessful test during this command";
8546         }
8547
8548         push @e, $self->{later} if $self->{later};
8549         push @e, $self->{configure_requires_later} if $self->{configure_requires_later};
8550
8551         if (exists $self->{build_dir}) {
8552             if (exists $self->{make_test}) {
8553                 if (
8554                     UNIVERSAL::can($self->{make_test},"failed") ?
8555                     $self->{make_test}->failed :
8556                     $self->{make_test} =~ /^NO/
8557                    ) {
8558                     if (
8559                         UNIVERSAL::can($self->{make_test},"commandid")
8560                         &&
8561                         $self->{make_test}->commandid == $CPAN::CurrentCommandId
8562                        ) {
8563                         push @e, "Has already been tested within this command";
8564                     }
8565                 } else {
8566                     push @e, "Has already been tested successfully";
8567                 }
8568             }
8569         } elsif (!@e) {
8570             push @e, "Has no own directory";
8571         }
8572         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
8573         unless (chdir $self->{build_dir}) {
8574             push @e, "Couldn't chdir to '$self->{build_dir}': $!";
8575         }
8576         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
8577     }
8578     $self->debug("Changed directory to $self->{build_dir}")
8579         if $CPAN::DEBUG;
8580
8581     if ($^O eq 'MacOS') {
8582         Mac::BuildTools::make_test($self);
8583         return;
8584     }
8585
8586     if ($self->{modulebuild}) {
8587         my $v = CPAN::Shell->expand("Module","Test::Harness")->inst_version;
8588         if (CPAN::Version->vlt($v,2.62)) {
8589             $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
8590   '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n});
8591             $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old");
8592             return;
8593         }
8594     }
8595
8596     my $system;
8597     my $prefs_test = $self->prefs->{test};
8598     if (my $commandline
8599         = exists $prefs_test->{commandline} ? $prefs_test->{commandline} : "") {
8600         $system = $commandline;
8601         $ENV{PERL} = CPAN::find_perl;
8602     } elsif ($self->{modulebuild}) {
8603         $system = sprintf "%s test", $self->_build_command();
8604     } else {
8605         $system = join " ", $self->_make_command(), "test";
8606     }
8607     my $make_test_arg = $self->make_x_arg("test");
8608     $system = sprintf("%s%s",
8609                       $system,
8610                       $make_test_arg ? " $make_test_arg" : "",
8611                      );
8612     my($tests_ok);
8613     my %env;
8614     while (my($k,$v) = each %ENV) {
8615         next unless defined $v;
8616         $env{$k} = $v;
8617     }
8618     local %ENV = %env;
8619     if (my $env = $self->prefs->{test}{env}) {
8620         for my $e (keys %$env) {
8621             $ENV{$e} = $env->{$e};
8622         }
8623     }
8624     my $expect_model = $self->_prefs_with_expect("test");
8625     my $want_expect = 0;
8626     if ( $expect_model && @{$expect_model->{talk}} ) {
8627         my $can_expect = $CPAN::META->has_inst("Expect");
8628         if ($can_expect) {
8629             $want_expect = 1;
8630         } else {
8631             $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
8632                                     "testing without\n");
8633         }
8634     }
8635     if ($want_expect) {
8636         if ($self->_should_report('test')) {
8637             $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ".
8638                                     "not supported when distroprefs specify ".
8639                                     "an interactive test\n");
8640         }
8641         $tests_ok = $self->_run_via_expect($system,$expect_model) == 0;
8642     } elsif ( $self->_should_report('test') ) {
8643         $tests_ok = CPAN::Reporter::test($self, $system);
8644     } else {
8645         $tests_ok = system($system) == 0;
8646     }
8647     $self->introduce_myself;
8648     if ( $tests_ok ) {
8649         {
8650             my @prereq;
8651
8652             # local $CPAN::DEBUG = 16; # Distribution
8653             for my $m (keys %{$self->{sponsored_mods}}) {
8654                 next unless $self->{sponsored_mods}{$m} > 0;
8655                 my $m_obj = CPAN::Shell->expand("Module",$m) or next;
8656                 # XXX we need available_version which reflects
8657                 # $ENV{PERL5LIB} so that already tested but not yet
8658                 # installed modules are counted.
8659                 my $available_version = $m_obj->available_version;
8660                 my $available_file = $m_obj->available_file;
8661                 if ($available_version &&
8662                     !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m})
8663                    ) {
8664                     CPAN->debug("m[$m] good enough available_version[$available_version]")
8665                         if $CPAN::DEBUG;
8666                 } elsif ($available_file
8667                          && (
8668                              !$self->{prereq_pm}{$m}
8669                              ||
8670                              $self->{prereq_pm}{$m} == 0
8671                             )
8672                         ) {
8673                     # lex Class::Accessor::Chained::Fast which has no $VERSION
8674                     CPAN->debug("m[$m] have available_file[$available_file]")
8675                         if $CPAN::DEBUG;
8676                 } else {
8677                     push @prereq, $m;
8678                 }
8679             }
8680             if (@prereq) {
8681                 my $cnt = @prereq;
8682                 my $which = join ",", @prereq;
8683                 my $but = $cnt == 1 ? "one dependency not OK ($which)" :
8684                     "$cnt dependencies missing ($which)";
8685                 $CPAN::Frontend->mywarn("Tests succeeded but $but\n");
8686                 $self->{make_test} = CPAN::Distrostatus->new("NO $but");
8687                 $self->store_persistent_state;
8688                 return $self->goodbye("[dependencies] -- NA");
8689             }
8690         }
8691
8692         $CPAN::Frontend->myprint("  $system -- OK\n");
8693         $self->{make_test} = CPAN::Distrostatus->new("YES");
8694         $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
8695         # probably impossible to need the next line because badtestcnt
8696         # has a lifespan of one command
8697         delete $self->{badtestcnt};
8698     } else {
8699         $self->{make_test} = CPAN::Distrostatus->new("NO");
8700         $self->{badtestcnt}++;
8701         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
8702         CPAN::Shell->optprint
8703               ("hint",
8704                sprintf
8705                ("//hint// to see the cpan-testers results for installing this module, try:
8706   reports %s\n",
8707                 $self->pretty_id));
8708     }
8709     $self->store_persistent_state;
8710 }
8711
8712 sub _prefs_with_expect {
8713     my($self,$where) = @_;
8714     return unless my $prefs = $self->prefs;
8715     return unless my $where_prefs = $prefs->{$where};
8716     if ($where_prefs->{expect}) {
8717         return {
8718                 mode => "deterministic",
8719                 timeout => 15,
8720                 talk => $where_prefs->{expect},
8721                };
8722     } elsif ($where_prefs->{"eexpect"}) {
8723         return $where_prefs->{"eexpect"};
8724     }
8725     return;
8726 }
8727
8728 #-> sub CPAN::Distribution::clean ;
8729 sub clean {
8730     my($self) = @_;
8731     my $make = $self->{modulebuild} ? "Build" : "make";
8732     $CPAN::Frontend->myprint("Running $make clean\n");
8733     unless (exists $self->{archived}) {
8734         $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped".
8735                                 "/untarred, nothing done\n");
8736         return 1;
8737     }
8738     unless (exists $self->{build_dir}) {
8739         $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
8740         return 1;
8741     }
8742     if (exists $self->{writemakefile}
8743         and $self->{writemakefile}->failed
8744        ) {
8745         $CPAN::Frontend->mywarn("No Makefile, don't know how to 'make clean'\n");
8746         return 1;
8747     }
8748   EXCUSE: {
8749         my @e;
8750         exists $self->{make_clean} and $self->{make_clean} eq "YES" and
8751             push @e, "make clean already called once";
8752         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
8753     }
8754     chdir $self->{build_dir} or
8755         Carp::confess("Couldn't chdir to $self->{build_dir}: $!");
8756     $self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG;
8757
8758     if ($^O eq 'MacOS') {
8759         Mac::BuildTools::make_clean($self);
8760         return;
8761     }
8762
8763     my $system;
8764     if ($self->{modulebuild}) {
8765         unless (-f "Build") {
8766             my $cwd = CPAN::anycwd();
8767             $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
8768                                     " in cwd[$cwd]. Danger, Will Robinson!");
8769             $CPAN::Frontend->mysleep(5);
8770         }
8771         $system = sprintf "%s clean", $self->_build_command();
8772     } else {
8773         $system  = join " ", $self->_make_command(), "clean";
8774     }
8775     my $system_ok = system($system) == 0;
8776     $self->introduce_myself;
8777     if ( $system_ok ) {
8778       $CPAN::Frontend->myprint("  $system -- OK\n");
8779
8780       # $self->force;
8781
8782       # Jost Krieger pointed out that this "force" was wrong because
8783       # it has the effect that the next "install" on this distribution
8784       # will untar everything again. Instead we should bring the
8785       # object's state back to where it is after untarring.
8786
8787       for my $k (qw(
8788                     force_update
8789                     install
8790                     writemakefile
8791                     make
8792                     make_test
8793                    )) {
8794           delete $self->{$k};
8795       }
8796       $self->{make_clean} = CPAN::Distrostatus->new("YES");
8797
8798     } else {
8799       # Hmmm, what to do if make clean failed?
8800
8801       $self->{make_clean} = CPAN::Distrostatus->new("NO");
8802       $CPAN::Frontend->mywarn(qq{  $system -- NOT OK\n});
8803
8804       # 2006-02-27: seems silly to me to force a make now
8805       # $self->force("make"); # so that this directory won't be used again
8806
8807     }
8808     $self->store_persistent_state;
8809 }
8810
8811 #-> sub CPAN::Distribution::goto ;
8812 sub goto {
8813     my($self,$goto) = @_;
8814     $goto = $self->normalize($goto);
8815     my $why = sprintf(
8816                       "Goto '$goto' via prefs file '%s' doc %d",
8817                       $self->{prefs_file},
8818                       $self->{prefs_file_doc},
8819                      );
8820     $self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
8821     # 2007-07-16 akoenig : Better than NA would be if we could inherit
8822     # the status of the $goto distro but given the exceptional nature
8823     # of 'goto' I feel reluctant to implement it
8824     my $goodbye_message = "[goto] -- NA $why";
8825     $self->goodbye($goodbye_message);
8826
8827     # inject into the queue
8828
8829     CPAN::Queue->delete($self->id);
8830     CPAN::Queue->jumpqueue({qmod => $goto, reqtype => $self->{reqtype}});
8831
8832     # and run where we left off
8833
8834     my($method) = (caller(1))[3];
8835     CPAN->instance("CPAN::Distribution",$goto)->$method();
8836     CPAN::Queue->delete_first($goto);
8837 }
8838
8839 #-> sub CPAN::Distribution::install ;
8840 sub install {
8841     my($self) = @_;
8842     if (my $goto = $self->prefs->{goto}) {
8843         return $self->goto($goto);
8844     }
8845     # $DB::single=1;
8846     unless ($self->{badtestcnt}) {
8847         $self->test;
8848     }
8849     if ($CPAN::Signal) {
8850       delete $self->{force_update};
8851       return;
8852     }
8853     my $make = $self->{modulebuild} ? "Build" : "make";
8854     $CPAN::Frontend->myprint("Running $make install\n");
8855   EXCUSE: {
8856         my @e;
8857         if ($self->{make} or $self->{later}) {
8858             # go ahead
8859         } else {
8860             push @e,
8861                 "Make had some problems, won't install";
8862         }
8863
8864         exists $self->{make} and
8865             (
8866              UNIVERSAL::can($self->{make},"failed") ?
8867              $self->{make}->failed :
8868              $self->{make} =~ /^NO/
8869             ) and
8870             push @e, "Make had returned bad status, install seems impossible";
8871
8872         if (exists $self->{build_dir}) {
8873         } elsif (!@e) {
8874             push @e, "Has no own directory";
8875         }
8876
8877         if (exists $self->{make_test} and
8878             (
8879              UNIVERSAL::can($self->{make_test},"failed") ?
8880              $self->{make_test}->failed :
8881              $self->{make_test} =~ /^NO/
8882             )) {
8883             if ($self->{force_update}) {
8884                 $self->{make_test}->text("FAILED but failure ignored because ".
8885                                          "'force' in effect");
8886             } else {
8887                 push @e, "make test had returned bad status, ".
8888                     "won't install without force"
8889             }
8890         }
8891         if (exists $self->{install}) {
8892             if (UNIVERSAL::can($self->{install},"text") ?
8893                 $self->{install}->text eq "YES" :
8894                 $self->{install} =~ /^YES/
8895                ) {
8896                 $CPAN::Frontend->myprint("  Already done\n");
8897                 $CPAN::META->is_installed($self->{build_dir});
8898                 return 1;
8899             } else {
8900                 # comment in Todo on 2006-02-11; maybe retry?
8901                 push @e, "Already tried without success";
8902             }
8903         }
8904
8905         push @e, $self->{later} if $self->{later};
8906         push @e, $self->{configure_requires_later} if $self->{configure_requires_later};
8907
8908         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
8909         unless (chdir $self->{build_dir}) {
8910             push @e, "Couldn't chdir to '$self->{build_dir}': $!";
8911         }
8912         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
8913     }
8914     $self->debug("Changed directory to $self->{build_dir}")
8915         if $CPAN::DEBUG;
8916
8917     if ($^O eq 'MacOS') {
8918         Mac::BuildTools::make_install($self);
8919         return;
8920     }
8921
8922     my $system;
8923     if (my $commandline = $self->prefs->{install}{commandline}) {
8924         $system = $commandline;
8925         $ENV{PERL} = CPAN::find_perl;
8926     } elsif ($self->{modulebuild}) {
8927         my($mbuild_install_build_command) =
8928             exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
8929                 $CPAN::Config->{mbuild_install_build_command} ?
8930                     $CPAN::Config->{mbuild_install_build_command} :
8931                         $self->_build_command();
8932         $system = sprintf("%s install %s",
8933                           $mbuild_install_build_command,
8934                           $CPAN::Config->{mbuild_install_arg},
8935                          );
8936     } else {
8937         my($make_install_make_command) =
8938             CPAN::HandleConfig->prefs_lookup($self,
8939                                              q{make_install_make_command})
8940                   || $self->_make_command();
8941         $system = sprintf("%s install %s",
8942                           $make_install_make_command,
8943                           $CPAN::Config->{make_install_arg},
8944                          );
8945     }
8946
8947     my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 ";
8948     my $brip = CPAN::HandleConfig->prefs_lookup($self,
8949                                                 q{build_requires_install_policy});
8950     $brip ||="ask/yes";
8951     my $id = $self->id;
8952     my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command
8953     my $want_install = "yes";
8954     if ($reqtype eq "b") {
8955         if ($brip eq "no") {
8956             $want_install = "no";
8957         } elsif ($brip =~ m|^ask/(.+)|) {
8958             my $default = $1;
8959             $default = "yes" unless $default =~ /^(y|n)/i;
8960             $want_install =
8961                 CPAN::Shell::colorable_makemaker_prompt
8962                       ("$id is just needed temporarily during building or testing. ".
8963                        "Do you want to install it permanently? (Y/n)",
8964                        $default);
8965         }
8966     }
8967     unless ($want_install =~ /^y/i) {
8968         my $is_only = "is only 'build_requires'";
8969         $CPAN::Frontend->mywarn("Not installing because $is_only\n");
8970         $self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
8971         delete $self->{force_update};
8972         return;
8973     }
8974     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
8975                            ? $ENV{PERL5LIB}
8976                            : ($ENV{PERLLIB} || "");
8977
8978     $CPAN::META->set_perl5lib;
8979     my($pipe) = FileHandle->new("$system $stderr |");
8980     my($makeout) = "";
8981     while (<$pipe>) {
8982         print $_; # intentionally NOT use Frontend->myprint because it
8983                   # looks irritating when we markup in color what we
8984                   # just pass through from an external program
8985         $makeout .= $_;
8986     }
8987     $pipe->close;
8988     my $close_ok = $? == 0;
8989     $self->introduce_myself;
8990     if ( $close_ok ) {
8991         $CPAN::Frontend->myprint("  $system -- OK\n");
8992         $CPAN::META->is_installed($self->{build_dir});
8993         $self->{install} = CPAN::Distrostatus->new("YES");
8994     } else {
8995         $self->{install} = CPAN::Distrostatus->new("NO");
8996         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
8997         my $mimc =
8998             CPAN::HandleConfig->prefs_lookup($self,
8999                                              q{make_install_make_command});
9000         if (
9001             $makeout =~ /permission/s
9002             && $> > 0
9003             && (
9004                 ! $mimc
9005                 || $mimc eq (CPAN::HandleConfig->prefs_lookup($self,
9006                                                               q{make}))
9007                )
9008            ) {
9009             $CPAN::Frontend->myprint(
9010                                      qq{----\n}.
9011                                      qq{  You may have to su }.
9012                                      qq{to root to install the package\n}.
9013                                      qq{  (Or you may want to run something like\n}.
9014                                      qq{    o conf make_install_make_command 'sudo make'\n}.
9015                                      qq{  to raise your permissions.}
9016                                     );
9017         }
9018     }
9019     delete $self->{force_update};
9020     # $DB::single = 1;
9021     $self->store_persistent_state;
9022 }
9023
9024 sub introduce_myself {
9025     my($self) = @_;
9026     $CPAN::Frontend->myprint(sprintf("  %s\n",$self->pretty_id));
9027 }
9028
9029 #-> sub CPAN::Distribution::dir ;
9030 sub dir {
9031     shift->{build_dir};
9032 }
9033
9034 #-> sub CPAN::Distribution::perldoc ;
9035 sub perldoc {
9036     my($self) = @_;
9037
9038     my($dist) = $self->id;
9039     my $package = $self->called_for;
9040
9041     $self->_display_url( $CPAN::Defaultdocs . $package );
9042 }
9043
9044 #-> sub CPAN::Distribution::_check_binary ;
9045 sub _check_binary {
9046     my ($dist,$shell,$binary) = @_;
9047     my ($pid,$out);
9048
9049     $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
9050       if $CPAN::DEBUG;
9051
9052     if ($CPAN::META->has_inst("File::Which")) {
9053         return File::Which::which($binary);
9054     } else {
9055         local *README;
9056         $pid = open README, "which $binary|"
9057             or $CPAN::Frontend->mywarn(qq{Could not fork 'which $binary': $!\n});
9058         return unless $pid;
9059         while (<README>) {
9060             $out .= $_;
9061         }
9062         close README
9063             or $CPAN::Frontend->mywarn("Could not run 'which $binary': $!\n")
9064                 and return;
9065     }
9066
9067     $CPAN::Frontend->myprint(qq{   + $out \n})
9068       if $CPAN::DEBUG && $out;
9069
9070     return $out;
9071 }
9072
9073 #-> sub CPAN::Distribution::_display_url ;
9074 sub _display_url {
9075     my($self,$url) = @_;
9076     my($res,$saved_file,$pid,$out);
9077
9078     $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
9079       if $CPAN::DEBUG;
9080
9081     # should we define it in the config instead?
9082     my $html_converter = "html2text.pl";
9083
9084     my $web_browser = $CPAN::Config->{'lynx'} || undef;
9085     my $web_browser_out = $web_browser
9086         ? CPAN::Distribution->_check_binary($self,$web_browser)
9087         : undef;
9088
9089     if ($web_browser_out) {
9090         # web browser found, run the action
9091         my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
9092         $CPAN::Frontend->myprint(qq{system[$browser $url]})
9093             if $CPAN::DEBUG;
9094         $CPAN::Frontend->myprint(qq{
9095 Displaying URL
9096   $url
9097 with browser $browser
9098 });
9099         $CPAN::Frontend->mysleep(1);
9100         system("$browser $url");
9101         if ($saved_file) { 1 while unlink($saved_file) }
9102     } else {
9103         # web browser not found, let's try text only
9104         my $html_converter_out =
9105             CPAN::Distribution->_check_binary($self,$html_converter);
9106         $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out);
9107
9108         if ($html_converter_out ) {
9109             # html2text found, run it
9110             $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
9111             $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n})
9112                 unless defined($saved_file);
9113
9114             local *README;
9115             $pid = open README, "$html_converter $saved_file |"
9116                 or $CPAN::Frontend->mydie(qq{
9117 Could not fork '$html_converter $saved_file': $!});
9118             my($fh,$filename);
9119             if ($CPAN::META->has_usable("File::Temp")) {
9120                 $fh = File::Temp->new(
9121                                       dir      => File::Spec->tmpdir,
9122                                       template => 'cpan_htmlconvert_XXXX',
9123                                       suffix => '.txt',
9124                                       unlink => 0,
9125                                      );
9126                 $filename = $fh->filename;
9127             } else {
9128                 $filename = "cpan_htmlconvert_$$.txt";
9129                 $fh = FileHandle->new();
9130                 open $fh, ">$filename" or die;
9131             }
9132             while (<README>) {
9133                 $fh->print($_);
9134             }
9135             close README or
9136                 $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
9137             my $tmpin = $fh->filename;
9138             $CPAN::Frontend->myprint(sprintf(qq{
9139 Run '%s %s' and
9140 saved output to %s\n},
9141                                              $html_converter,
9142                                              $saved_file,
9143                                              $tmpin,
9144                                             )) if $CPAN::DEBUG;
9145             close $fh;
9146             local *FH;
9147             open FH, $tmpin
9148                 or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
9149             my $fh_pager = FileHandle->new;
9150             local($SIG{PIPE}) = "IGNORE";
9151             my $pager = $CPAN::Config->{'pager'} || "cat";
9152             $fh_pager->open("|$pager")
9153                 or $CPAN::Frontend->mydie(qq{
9154 Could not open pager '$pager': $!});
9155             $CPAN::Frontend->myprint(qq{
9156 Displaying URL
9157   $url
9158 with pager "$pager"
9159 });
9160             $CPAN::Frontend->mysleep(1);
9161             $fh_pager->print(<FH>);
9162             $fh_pager->close;
9163         } else {
9164             # coldn't find the web browser or html converter
9165             $CPAN::Frontend->myprint(qq{
9166 You need to install lynx or $html_converter to use this feature.});
9167         }
9168     }
9169 }
9170
9171 #-> sub CPAN::Distribution::_getsave_url ;
9172 sub _getsave_url {
9173     my($dist, $shell, $url) = @_;
9174
9175     $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
9176       if $CPAN::DEBUG;
9177
9178     my($fh,$filename);
9179     if ($CPAN::META->has_usable("File::Temp")) {
9180         $fh = File::Temp->new(
9181                               dir      => File::Spec->tmpdir,
9182                               template => "cpan_getsave_url_XXXX",
9183                               suffix => ".html",
9184                               unlink => 0,
9185                              );
9186         $filename = $fh->filename;
9187     } else {
9188         $fh = FileHandle->new;
9189         $filename = "cpan_getsave_url_$$.html";
9190     }
9191     my $tmpin = $filename;
9192     if ($CPAN::META->has_usable('LWP')) {
9193         $CPAN::Frontend->myprint("Fetching with LWP:
9194   $url
9195 ");
9196         my $Ua;
9197         CPAN::LWP::UserAgent->config;
9198         eval { $Ua = CPAN::LWP::UserAgent->new; };
9199         if ($@) {
9200             $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
9201             return;
9202         } else {
9203             my($var);
9204             $Ua->proxy('http', $var)
9205                 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
9206             $Ua->no_proxy($var)
9207                 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
9208         }
9209
9210         my $req = HTTP::Request->new(GET => $url);
9211         $req->header('Accept' => 'text/html');
9212         my $res = $Ua->request($req);
9213         if ($res->is_success) {
9214             $CPAN::Frontend->myprint(" + request successful.\n")
9215                 if $CPAN::DEBUG;
9216             print $fh $res->content;
9217             close $fh;
9218             $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
9219                 if $CPAN::DEBUG;
9220             return $tmpin;
9221         } else {
9222             $CPAN::Frontend->myprint(sprintf(
9223                                              "LWP failed with code[%s], message[%s]\n",
9224                                              $res->code,
9225                                              $res->message,
9226                                             ));
9227             return;
9228         }
9229     } else {
9230         $CPAN::Frontend->mywarn("  LWP not available\n");
9231         return;
9232     }
9233 }
9234
9235 #-> sub CPAN::Distribution::_build_command
9236 sub _build_command {
9237     my($self) = @_;
9238     if ($^O eq "MSWin32") { # special code needed at least up to
9239                             # Module::Build 0.2611 and 0.2706; a fix
9240                             # in M:B has been promised 2006-01-30
9241         my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
9242         return "$perl ./Build";
9243     }
9244     return "./Build";
9245 }
9246
9247 #-> sub CPAN::Distribution::_should_report
9248 sub _should_report {
9249     my($self, $phase) = @_;
9250     die "_should_report() requires a 'phase' argument"
9251         if ! defined $phase;
9252
9253     # configured
9254     my $test_report = CPAN::HandleConfig->prefs_lookup($self,
9255                                                        q{test_report});
9256     return unless $test_report;
9257
9258     # don't repeat if we cached a result
9259     return $self->{should_report}
9260         if exists $self->{should_report};
9261
9262     # available
9263     if ( ! $CPAN::META->has_inst("CPAN::Reporter")) {
9264         $CPAN::Frontend->mywarn(
9265             "CPAN::Reporter not installed.  No reports will be sent.\n"
9266         );
9267         return $self->{should_report} = 0;
9268     }
9269
9270     # capable
9271     my $crv = CPAN::Reporter->VERSION;
9272     if ( CPAN::Version->vlt( $crv, 0.99 ) ) {
9273         # don't cache $self->{should_report} -- need to check each phase
9274         if ( $phase eq 'test' ) {
9275             return 1;
9276         }
9277         else {
9278             $CPAN::Frontend->mywarn(
9279                 "Reporting on the '$phase' phase requires CPAN::Reporter 0.99, but \n" .
9280                 "you only have version $crv\.  Only 'test' phase reports will be sent.\n"
9281             );
9282             return;
9283         }
9284     }
9285
9286     # appropriate
9287     if ($self->is_dot_dist) {
9288         $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
9289                                 "for local directories\n");
9290         return $self->{should_report} = 0;
9291     }
9292     if ($self->prefs->{patches}
9293         &&
9294         @{$self->prefs->{patches}}
9295         &&
9296         $self->{patched}
9297        ) {
9298         $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
9299                                 "when the source has been patched\n");
9300         return $self->{should_report} = 0;
9301     }
9302
9303     # proceed and cache success
9304     return $self->{should_report} = 1;
9305 }
9306
9307 #-> sub CPAN::Distribution::reports
9308 sub reports {
9309     my($self) = @_;
9310     my $pathname = $self->id;
9311     $CPAN::Frontend->myprint("Distribution: $pathname\n");
9312
9313     unless ($CPAN::META->has_inst("CPAN::DistnameInfo")) {
9314         $CPAN::Frontend->mydie("CPAN::DistnameInfo not installed; cannot continue");
9315     }
9316     unless ($CPAN::META->has_usable("LWP")) {
9317         $CPAN::Frontend->mydie("LWP not installed; cannot continue");
9318     }
9319     unless ($CPAN::META->has_usable("File::Temp")) {
9320         $CPAN::Frontend->mydie("File::Temp not installed; cannot continue");
9321     }
9322
9323     my $d = CPAN::DistnameInfo->new($pathname);
9324
9325     my $dist      = $d->dist;      # "CPAN-DistnameInfo"
9326     my $version   = $d->version;   # "0.02"
9327     my $maturity  = $d->maturity;  # "released"
9328     my $filename  = $d->filename;  # "CPAN-DistnameInfo-0.02.tar.gz"
9329     my $cpanid    = $d->cpanid;    # "GBARR"
9330     my $distvname = $d->distvname; # "CPAN-DistnameInfo-0.02"
9331
9332     my $url = sprintf "http://cpantesters.perl.org/show/%s.yaml", $dist;
9333
9334     CPAN::LWP::UserAgent->config;
9335     my $Ua;
9336     eval { $Ua = CPAN::LWP::UserAgent->new; };
9337     if ($@) {
9338         $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
9339     }
9340     $CPAN::Frontend->myprint("Fetching '$url'...");
9341     my $resp = $Ua->get($url);
9342     unless ($resp->is_success) {
9343         $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
9344     }
9345     $CPAN::Frontend->myprint("DONE\n\n");
9346     my $yaml = $resp->content;
9347     # was fuer ein Umweg!
9348     my $fh = File::Temp->new(
9349                              dir      => File::Spec->tmpdir,
9350                              template => 'cpan_reports_XXXX',
9351                              suffix => '.yaml',
9352                              unlink => 0,
9353                             );
9354     my $tfilename = $fh->filename;
9355     print $fh $yaml;
9356     close $fh or $CPAN::Frontend->mydie("Could not close '$tfilename': $!");
9357     my $unserialized = CPAN->_yaml_loadfile($tfilename)->[0];
9358     unlink $tfilename or $CPAN::Frontend->mydie("Could not unlink '$tfilename': $!");
9359     my %other_versions;
9360     my $this_version_seen;
9361     for my $rep (@$unserialized) {
9362         my $rversion = $rep->{version};
9363         if ($rversion eq $version) {
9364             unless ($this_version_seen++) {
9365                 $CPAN::Frontend->myprint ("$rep->{version}:\n");
9366             }
9367             $CPAN::Frontend->myprint
9368                 (sprintf("%1s%1s%-4s %s on %s %s (%s)\n",
9369                          $rep->{archname} eq $Config::Config{archname}?"*":"",
9370                          $rep->{action}eq"PASS"?"+":$rep->{action}eq"FAIL"?"-":"",
9371                          $rep->{action},
9372                          $rep->{perl},
9373                          ucfirst $rep->{osname},
9374                          $rep->{osvers},
9375                          $rep->{archname},
9376                         ));
9377         } else {
9378             $other_versions{$rep->{version}}++;
9379         }
9380     }
9381     unless ($this_version_seen) {
9382         $CPAN::Frontend->myprint("No reports found for version '$version'
9383 Reports for other versions:\n");
9384         for my $v (sort keys %other_versions) {
9385             $CPAN::Frontend->myprint(" $v\: $other_versions{$v}\n");
9386         }
9387     }
9388     $url =~ s/\.yaml/.html/;
9389     $CPAN::Frontend->myprint("See $url for details\n");
9390 }
9391
9392 package CPAN::Bundle;
9393 use strict;
9394
9395 sub look {
9396     my $self = shift;
9397     $CPAN::Frontend->myprint($self->as_string);
9398 }
9399
9400 #-> CPAN::Bundle::undelay
9401 sub undelay {
9402     my $self = shift;
9403     delete $self->{later};
9404     for my $c ( $self->contains ) {
9405         my $obj = CPAN::Shell->expandany($c) or next;
9406         $obj->undelay;
9407     }
9408 }
9409
9410 # mark as dirty/clean
9411 #-> sub CPAN::Bundle::color_cmd_tmps ;
9412 sub color_cmd_tmps {
9413     my($self) = shift;
9414     my($depth) = shift || 0;
9415     my($color) = shift || 0;
9416     my($ancestors) = shift || [];
9417     # a module needs to recurse to its cpan_file, a distribution needs
9418     # to recurse into its prereq_pms, a bundle needs to recurse into its modules
9419
9420     return if exists $self->{incommandcolor}
9421         && $color==1
9422         && $self->{incommandcolor}==$color;
9423     if ($depth>=$CPAN::MAX_RECURSION) {
9424         die(CPAN::Exception::RecursiveDependency->new($ancestors));
9425     }
9426     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
9427
9428     for my $c ( $self->contains ) {
9429         my $obj = CPAN::Shell->expandany($c) or next;
9430         CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
9431         $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
9432     }
9433     # never reached code?
9434     #if ($color==0) {
9435       #delete $self->{badtestcnt};
9436     #}
9437     $self->{incommandcolor} = $color;
9438 }
9439
9440 #-> sub CPAN::Bundle::as_string ;
9441 sub as_string {
9442     my($self) = @_;
9443     $self->contains;
9444     # following line must be "=", not "||=" because we have a moving target
9445     $self->{INST_VERSION} = $self->inst_version;
9446     return $self->SUPER::as_string;
9447 }
9448
9449 #-> sub CPAN::Bundle::contains ;
9450 sub contains {
9451     my($self) = @_;
9452     my($inst_file) = $self->inst_file || "";
9453     my($id) = $self->id;
9454     $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
9455     if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) {
9456         undef $inst_file;
9457     }
9458     unless ($inst_file) {
9459         # Try to get at it in the cpan directory
9460         $self->debug("no inst_file") if $CPAN::DEBUG;
9461         my $cpan_file;
9462         $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
9463               $cpan_file = $self->cpan_file;
9464         if ($cpan_file eq "N/A") {
9465             $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
9466   Maybe stale symlink? Maybe removed during session? Giving up.\n");
9467         }
9468         my $dist = $CPAN::META->instance('CPAN::Distribution',
9469                                          $self->cpan_file);
9470         $self->debug("before get id[$dist->{ID}]") if $CPAN::DEBUG;
9471         $dist->get;
9472         $self->debug("after get id[$dist->{ID}]") if $CPAN::DEBUG;
9473         my($todir) = $CPAN::Config->{'cpan_home'};
9474         my(@me,$from,$to,$me);
9475         @me = split /::/, $self->id;
9476         $me[-1] .= ".pm";
9477         $me = File::Spec->catfile(@me);
9478         $from = $self->find_bundle_file($dist->{build_dir},join('/',@me));
9479         $to = File::Spec->catfile($todir,$me);
9480         File::Path::mkpath(File::Basename::dirname($to));
9481         File::Copy::copy($from, $to)
9482               or Carp::confess("Couldn't copy $from to $to: $!");
9483         $inst_file = $to;
9484     }
9485     my @result;
9486     my $fh = FileHandle->new;
9487     local $/ = "\n";
9488     open($fh,$inst_file) or die "Could not open '$inst_file': $!";
9489     my $in_cont = 0;
9490     $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
9491     while (<$fh>) {
9492         $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
9493             m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
9494         next unless $in_cont;
9495         next if /^=/;
9496         s/\#.*//;
9497         next if /^\s+$/;
9498         chomp;
9499         push @result, (split " ", $_, 2)[0];
9500     }
9501     close $fh;
9502     delete $self->{STATUS};
9503     $self->{CONTAINS} = \@result;
9504     $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
9505     unless (@result) {
9506         $CPAN::Frontend->mywarn(qq{
9507 The bundle file "$inst_file" may be a broken
9508 bundlefile. It seems not to contain any bundle definition.
9509 Please check the file and if it is bogus, please delete it.
9510 Sorry for the inconvenience.
9511 });
9512     }
9513     @result;
9514 }
9515
9516 #-> sub CPAN::Bundle::find_bundle_file
9517 # $where is in local format, $what is in unix format
9518 sub find_bundle_file {
9519     my($self,$where,$what) = @_;
9520     $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
9521 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
9522 ###    my $bu = File::Spec->catfile($where,$what);
9523 ###    return $bu if -f $bu;
9524     my $manifest = File::Spec->catfile($where,"MANIFEST");
9525     unless (-f $manifest) {
9526         require ExtUtils::Manifest;
9527         my $cwd = CPAN::anycwd();
9528         $self->safe_chdir($where);
9529         ExtUtils::Manifest::mkmanifest();
9530         $self->safe_chdir($cwd);
9531     }
9532     my $fh = FileHandle->new($manifest)
9533         or Carp::croak("Couldn't open $manifest: $!");
9534     local($/) = "\n";
9535     my $bundle_filename = $what;
9536     $bundle_filename =~ s|Bundle.*/||;
9537     my $bundle_unixpath;
9538     while (<$fh>) {
9539         next if /^\s*\#/;
9540         my($file) = /(\S+)/;
9541         if ($file =~ m|\Q$what\E$|) {
9542             $bundle_unixpath = $file;
9543             # return File::Spec->catfile($where,$bundle_unixpath); # bad
9544             last;
9545         }
9546         # retry if she managed to have no Bundle directory
9547         $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
9548     }
9549     return File::Spec->catfile($where, split /\//, $bundle_unixpath)
9550         if $bundle_unixpath;
9551     Carp::croak("Couldn't find a Bundle file in $where");
9552 }
9553
9554 # needs to work quite differently from Module::inst_file because of
9555 # cpan_home/Bundle/ directory and the possibility that we have
9556 # shadowing effect. As it makes no sense to take the first in @INC for
9557 # Bundles, we parse them all for $VERSION and take the newest.
9558
9559 #-> sub CPAN::Bundle::inst_file ;
9560 sub inst_file {
9561     my($self) = @_;
9562     my($inst_file);
9563     my(@me);
9564     @me = split /::/, $self->id;
9565     $me[-1] .= ".pm";
9566     my($incdir,$bestv);
9567     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
9568         my $bfile = File::Spec->catfile($incdir, @me);
9569         CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
9570         next unless -f $bfile;
9571         my $foundv = MM->parse_version($bfile);
9572         if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
9573             $self->{INST_FILE} = $bfile;
9574             $self->{INST_VERSION} = $bestv = $foundv;
9575         }
9576     }
9577     $self->{INST_FILE};
9578 }
9579
9580 #-> sub CPAN::Bundle::inst_version ;
9581 sub inst_version {
9582     my($self) = @_;
9583     $self->inst_file; # finds INST_VERSION as side effect
9584     $self->{INST_VERSION};
9585 }
9586
9587 #-> sub CPAN::Bundle::rematein ;
9588 sub rematein {
9589     my($self,$meth) = @_;
9590     $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
9591     my($id) = $self->id;
9592     Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
9593         unless $self->inst_file || $self->cpan_file;
9594     my($s,%fail);
9595     for $s ($self->contains) {
9596         my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
9597             $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
9598         if ($type eq 'CPAN::Distribution') {
9599             $CPAN::Frontend->mywarn(qq{
9600 The Bundle }.$self->id.qq{ contains
9601 explicitly a file '$s'.
9602 Going to $meth that.
9603 });
9604             $CPAN::Frontend->mysleep(5);
9605         }
9606         # possibly noisy action:
9607         $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
9608         my $obj = $CPAN::META->instance($type,$s);
9609         $obj->{reqtype} = $self->{reqtype};
9610         $obj->$meth();
9611     }
9612 }
9613
9614 # If a bundle contains another that contains an xs_file we have here,
9615 # we just don't bother I suppose
9616 #-> sub CPAN::Bundle::xs_file
9617 sub xs_file {
9618     return 0;
9619 }
9620
9621 #-> sub CPAN::Bundle::force ;
9622 sub fforce   { shift->rematein('fforce',@_); }
9623 #-> sub CPAN::Bundle::force ;
9624 sub force   { shift->rematein('force',@_); }
9625 #-> sub CPAN::Bundle::notest ;
9626 sub notest  { shift->rematein('notest',@_); }
9627 #-> sub CPAN::Bundle::get ;
9628 sub get     { shift->rematein('get',@_); }
9629 #-> sub CPAN::Bundle::make ;
9630 sub make    { shift->rematein('make',@_); }
9631 #-> sub CPAN::Bundle::test ;
9632 sub test    {
9633     my $self = shift;
9634     # $self->{badtestcnt} ||= 0;
9635     $self->rematein('test',@_);
9636 }
9637 #-> sub CPAN::Bundle::install ;
9638 sub install {
9639   my $self = shift;
9640   $self->rematein('install',@_);
9641 }
9642 #-> sub CPAN::Bundle::clean ;
9643 sub clean   { shift->rematein('clean',@_); }
9644
9645 #-> sub CPAN::Bundle::uptodate ;
9646 sub uptodate {
9647     my($self) = @_;
9648     return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
9649     my $c;
9650     foreach $c ($self->contains) {
9651         my $obj = CPAN::Shell->expandany($c);
9652         return 0 unless $obj->uptodate;
9653     }
9654     return 1;
9655 }
9656
9657 #-> sub CPAN::Bundle::readme ;
9658 sub readme  {
9659     my($self) = @_;
9660     my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
9661 No File found for bundle } . $self->id . qq{\n}), return;
9662     $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
9663     $CPAN::META->instance('CPAN::Distribution',$file)->readme;
9664 }
9665
9666 package CPAN::Module;
9667 use strict;
9668
9669 # Accessors
9670 #-> sub CPAN::Module::userid
9671 sub userid {
9672     my $self = shift;
9673     my $ro = $self->ro;
9674     return unless $ro;
9675     return $ro->{userid} || $ro->{CPAN_USERID};
9676 }
9677 #-> sub CPAN::Module::description
9678 sub description {
9679     my $self = shift;
9680     my $ro = $self->ro or return "";
9681     $ro->{description}
9682 }
9683
9684 #-> sub CPAN::Module::distribution
9685 sub distribution {
9686     my($self) = @_;
9687     CPAN::Shell->expand("Distribution",$self->cpan_file);
9688 }
9689
9690 #-> sub CPAN::Module::undelay
9691 sub undelay {
9692     my $self = shift;
9693     delete $self->{later};
9694     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
9695         $dist->undelay;
9696     }
9697 }
9698
9699 # mark as dirty/clean
9700 #-> sub CPAN::Module::color_cmd_tmps ;
9701 sub color_cmd_tmps {
9702     my($self) = shift;
9703     my($depth) = shift || 0;
9704     my($color) = shift || 0;
9705     my($ancestors) = shift || [];
9706     # a module needs to recurse to its cpan_file
9707
9708     return if exists $self->{incommandcolor}
9709         && $color==1
9710         && $self->{incommandcolor}==$color;
9711     return if $color==0 && !$self->{incommandcolor};
9712     if ($color>=1) {
9713         if ( $self->uptodate ) {
9714             $self->{incommandcolor} = $color;
9715             return;
9716         } elsif (my $have_version = $self->available_version) {
9717             # maybe what we have is good enough
9718             if (@$ancestors) {
9719                 my $who_asked_for_me = $ancestors->[-1];
9720                 my $obj = CPAN::Shell->expandany($who_asked_for_me);
9721                 if (0) {
9722                 } elsif ($obj->isa("CPAN::Bundle")) {
9723                     # bundles cannot specify a minimum version
9724                     return;
9725                 } elsif ($obj->isa("CPAN::Distribution")) {
9726                     if (my $prereq_pm = $obj->prereq_pm) {
9727                         for my $k (keys %$prereq_pm) {
9728                             if (my $want_version = $prereq_pm->{$k}{$self->id}) {
9729                                 if (CPAN::Version->vcmp($have_version,$want_version) >= 0) {
9730                                     $self->{incommandcolor} = $color;
9731                                     return;
9732                                 }
9733                             }
9734                         }
9735                     }
9736                 }
9737             }
9738         }
9739     } else {
9740         $self->{incommandcolor} = $color; # set me before recursion,
9741                                           # so we can break it
9742     }
9743     if ($depth>=$CPAN::MAX_RECURSION) {
9744         die(CPAN::Exception::RecursiveDependency->new($ancestors));
9745     }
9746     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
9747
9748     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
9749         $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
9750     }
9751     # unreached code?
9752     # if ($color==0) {
9753     #    delete $self->{badtestcnt};
9754     # }
9755     $self->{incommandcolor} = $color;
9756 }
9757
9758 #-> sub CPAN::Module::as_glimpse ;
9759 sub as_glimpse {
9760     my($self) = @_;
9761     my(@m);
9762     my $class = ref($self);
9763     $class =~ s/^CPAN:://;
9764     my $color_on = "";
9765     my $color_off = "";
9766     if (
9767         $CPAN::Shell::COLOR_REGISTERED
9768         &&
9769         $CPAN::META->has_inst("Term::ANSIColor")
9770         &&
9771         $self->description
9772        ) {
9773         $color_on = Term::ANSIColor::color("green");
9774         $color_off = Term::ANSIColor::color("reset");
9775     }
9776     my $uptodateness = " ";
9777     unless ($class eq "Bundle") {
9778         my $u = $self->uptodate;
9779         $uptodateness = $u ? "=" : "<" if defined $u;
9780     };
9781     my $id = do {
9782         my $d = $self->distribution;
9783         $d ? $d -> pretty_id : $self->cpan_userid;
9784     };
9785     push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n",
9786                      $class,
9787                      $uptodateness,
9788                      $color_on,
9789                      $self->id,
9790                      $color_off,
9791                      $id,
9792                     );
9793     join "", @m;
9794 }
9795
9796 #-> sub CPAN::Module::dslip_status
9797 sub dslip_status {
9798     my($self) = @_;
9799     my($stat);
9800     # development status
9801     @{$stat->{D}}{qw,i c a b R M S,}     = qw,idea
9802                                               pre-alpha alpha beta released
9803                                               mature standard,;
9804     # support level
9805     @{$stat->{S}}{qw,m d u n a,}         = qw,mailing-list
9806                                               developer comp.lang.perl.*
9807                                               none abandoned,;
9808     # language
9809     @{$stat->{L}}{qw,p c + o h,}         = qw,perl C C++ other hybrid,;
9810     # interface
9811     @{$stat->{I}}{qw,f r O p h n,}       = qw,functions
9812                                               references+ties
9813                                               object-oriented pragma
9814                                               hybrid none,;
9815     # public licence
9816     @{$stat->{P}}{qw,p g l b a 2 o d r n,} = qw,Standard-Perl
9817                                               GPL LGPL
9818                                               BSD Artistic Artistic_2
9819                                               open-source
9820                                               distribution_allowed
9821                                               restricted_distribution
9822                                               no_licence,;
9823     for my $x (qw(d s l i p)) {
9824         $stat->{$x}{' '} = 'unknown';
9825         $stat->{$x}{'?'} = 'unknown';
9826     }
9827     my $ro = $self->ro;
9828     return +{} unless $ro && $ro->{statd};
9829     return {
9830             D  => $ro->{statd},
9831             S  => $ro->{stats},
9832             L  => $ro->{statl},
9833             I  => $ro->{stati},
9834             P  => $ro->{statp},
9835             DV => $stat->{D}{$ro->{statd}},
9836             SV => $stat->{S}{$ro->{stats}},
9837             LV => $stat->{L}{$ro->{statl}},
9838             IV => $stat->{I}{$ro->{stati}},
9839             PV => $stat->{P}{$ro->{statp}},
9840            };
9841 }
9842
9843 #-> sub CPAN::Module::as_string ;
9844 sub as_string {
9845     my($self) = @_;
9846     my(@m);
9847     CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
9848     my $class = ref($self);
9849     $class =~ s/^CPAN:://;
9850     local($^W) = 0;
9851     push @m, $class, " id = $self->{ID}\n";
9852     my $sprintf = "    %-12s %s\n";
9853     push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
9854         if $self->description;
9855     my $sprintf2 = "    %-12s %s (%s)\n";
9856     my($userid);
9857     $userid = $self->userid;
9858     if ( $userid ) {
9859         my $author;
9860         if ($author = CPAN::Shell->expand('Author',$userid)) {
9861             my $email = "";
9862             my $m; # old perls
9863             if ($m = $author->email) {
9864                 $email = " <$m>";
9865             }
9866             push @m, sprintf(
9867                              $sprintf2,
9868                              'CPAN_USERID',
9869                              $userid,
9870                              $author->fullname . $email
9871                             );
9872         }
9873     }
9874     push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
9875         if $self->cpan_version;
9876     if (my $cpan_file = $self->cpan_file) {
9877         push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
9878         if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
9879             my $upload_date = $dist->upload_date;
9880             if ($upload_date) {
9881                 push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
9882             }
9883         }
9884     }
9885     my $sprintf3 = "    %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n";
9886     my $dslip = $self->dslip_status;
9887     push @m, sprintf(
9888                      $sprintf3,
9889                      'DSLIP_STATUS',
9890                      @{$dslip}{qw(D S L I P DV SV LV IV PV)},
9891                     ) if $dslip->{D};
9892     my $local_file = $self->inst_file;
9893     unless ($self->{MANPAGE}) {
9894         my $manpage;
9895         if ($local_file) {
9896             $manpage = $self->manpage_headline($local_file);
9897         } else {
9898             # If we have already untarred it, we should look there
9899             my $dist = $CPAN::META->instance('CPAN::Distribution',
9900                                              $self->cpan_file);
9901             # warn "dist[$dist]";
9902             # mff=manifest file; mfh=manifest handle
9903             my($mff,$mfh);
9904             if (
9905                 $dist->{build_dir}
9906                 and
9907                 (-f  ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
9908                 and
9909                 $mfh = FileHandle->new($mff)
9910                ) {
9911                 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
9912                 my $lfre = $self->id; # local file RE
9913                 $lfre =~ s/::/./g;
9914                 $lfre .= "\\.pm\$";
9915                 my($lfl); # local file file
9916                 local $/ = "\n";
9917                 my(@mflines) = <$mfh>;
9918                 for (@mflines) {
9919                     s/^\s+//;
9920                     s/\s.*//s;
9921                 }
9922                 while (length($lfre)>5 and !$lfl) {
9923                     ($lfl) = grep /$lfre/, @mflines;
9924                     CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
9925                     $lfre =~ s/.+?\.//;
9926                 }
9927                 $lfl =~ s/\s.*//; # remove comments
9928                 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
9929                 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
9930                 # warn "lfl_abs[$lfl_abs]";
9931                 if (-f $lfl_abs) {
9932                     $manpage = $self->manpage_headline($lfl_abs);
9933                 }
9934             }
9935         }
9936         $self->{MANPAGE} = $manpage if $manpage;
9937     }
9938     my($item);
9939     for $item (qw/MANPAGE/) {
9940         push @m, sprintf($sprintf, $item, $self->{$item})
9941             if exists $self->{$item};
9942     }
9943     for $item (qw/CONTAINS/) {
9944         push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
9945             if exists $self->{$item} && @{$self->{$item}};
9946     }
9947     push @m, sprintf($sprintf, 'INST_FILE',
9948                      $local_file || "(not installed)");
9949     push @m, sprintf($sprintf, 'INST_VERSION',
9950                      $self->inst_version) if $local_file;
9951     join "", @m, "\n";
9952 }
9953
9954 #-> sub CPAN::Module::manpage_headline
9955 sub manpage_headline {
9956     my($self,$local_file) = @_;
9957     my(@local_file) = $local_file;
9958     $local_file =~ s/\.pm(?!\n)\Z/.pod/;
9959     push @local_file, $local_file;
9960     my(@result,$locf);
9961     for $locf (@local_file) {
9962         next unless -f $locf;
9963         my $fh = FileHandle->new($locf)
9964             or $Carp::Frontend->mydie("Couldn't open $locf: $!");
9965         my $inpod = 0;
9966         local $/ = "\n";
9967         while (<$fh>) {
9968             $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
9969                 m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
9970             next unless $inpod;
9971             next if /^=/;
9972             next if /^\s+$/;
9973             chomp;
9974             push @result, $_;
9975         }
9976         close $fh;
9977         last if @result;
9978     }
9979     for (@result) {
9980         s/^\s+//;
9981         s/\s+$//;
9982     }
9983     join " ", @result;
9984 }
9985
9986 #-> sub CPAN::Module::cpan_file ;
9987 # Note: also inherited by CPAN::Bundle
9988 sub cpan_file {
9989     my $self = shift;
9990     # CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
9991     unless ($self->ro) {
9992         CPAN::Index->reload;
9993     }
9994     my $ro = $self->ro;
9995     if ($ro && defined $ro->{CPAN_FILE}) {
9996         return $ro->{CPAN_FILE};
9997     } else {
9998         my $userid = $self->userid;
9999         if ( $userid ) {
10000             if ($CPAN::META->exists("CPAN::Author",$userid)) {
10001                 my $author = $CPAN::META->instance("CPAN::Author",
10002                                                    $userid);
10003                 my $fullname = $author->fullname;
10004                 my $email = $author->email;
10005                 unless (defined $fullname && defined $email) {
10006                     return sprintf("Contact Author %s",
10007                                    $userid,
10008                                   );
10009                 }
10010                 return "Contact Author $fullname <$email>";
10011             } else {
10012                 return "Contact Author $userid (Email address not available)";
10013             }
10014         } else {
10015             return "N/A";
10016         }
10017     }
10018 }
10019
10020 #-> sub CPAN::Module::cpan_version ;
10021 sub cpan_version {
10022     my $self = shift;
10023
10024     my $ro = $self->ro;
10025     unless ($ro) {
10026         # Can happen with modules that are not on CPAN
10027         $ro = {};
10028     }
10029     $ro->{CPAN_VERSION} = 'undef'
10030         unless defined $ro->{CPAN_VERSION};
10031     $ro->{CPAN_VERSION};
10032 }
10033
10034 #-> sub CPAN::Module::force ;
10035 sub force {
10036     my($self) = @_;
10037     $self->{force_update} = 1;
10038 }
10039
10040 #-> sub CPAN::Module::fforce ;
10041 sub fforce {
10042     my($self) = @_;
10043     $self->{force_update} = 2;
10044 }
10045
10046 #-> sub CPAN::Module::notest ;
10047 sub notest {
10048     my($self) = @_;
10049     # $CPAN::Frontend->mywarn("XDEBUG: set notest for Module");
10050     $self->{notest}++;
10051 }
10052
10053 #-> sub CPAN::Module::rematein ;
10054 sub rematein {
10055     my($self,$meth) = @_;
10056     $CPAN::Frontend->myprint(sprintf("Running %s for module '%s'\n",
10057                                      $meth,
10058                                      $self->id));
10059     my $cpan_file = $self->cpan_file;
10060     if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/) {
10061         $CPAN::Frontend->mywarn(sprintf qq{
10062   The module %s isn\'t available on CPAN.
10063
10064   Either the module has not yet been uploaded to CPAN, or it is
10065   temporary unavailable. Please contact the author to find out
10066   more about the status. Try 'i %s'.
10067 },
10068                                 $self->id,
10069                                 $self->id,
10070                                );
10071         return;
10072     }
10073     my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
10074     $pack->called_for($self->id);
10075     if (exists $self->{force_update}) {
10076         if ($self->{force_update} == 2) {
10077             $pack->fforce($meth);
10078         } else {
10079             $pack->force($meth);
10080         }
10081     }
10082     $pack->notest($meth) if exists $self->{notest} && $self->{notest};
10083
10084     $pack->{reqtype} ||= "";
10085     CPAN->debug("dist-reqtype[$pack->{reqtype}]".
10086                 "self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG;
10087         if ($pack->{reqtype}) {
10088             if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) {
10089                 $pack->{reqtype} = $self->{reqtype};
10090                 if (
10091                     exists $pack->{install}
10092                     &&
10093                     (
10094                      UNIVERSAL::can($pack->{install},"failed") ?
10095                      $pack->{install}->failed :
10096                      $pack->{install} =~ /^NO/
10097                     )
10098                    ) {
10099                     delete $pack->{install};
10100                     $CPAN::Frontend->mywarn
10101                         ("Promoting $pack->{ID} from 'build_requires' to 'requires'");
10102                 }
10103             }
10104         } else {
10105             $pack->{reqtype} = $self->{reqtype};
10106         }
10107
10108     my $success = eval {
10109         $pack->$meth();
10110     };
10111     my $err = $@;
10112     $pack->unforce if $pack->can("unforce") && exists $self->{force_update};
10113     $pack->unnotest if $pack->can("unnotest") && exists $self->{notest};
10114     delete $self->{force_update};
10115     delete $self->{notest};
10116     if ($err) {
10117         die $err;
10118     }
10119     return $success;
10120 }
10121
10122 #-> sub CPAN::Module::perldoc ;
10123 sub perldoc { shift->rematein('perldoc') }
10124 #-> sub CPAN::Module::readme ;
10125 sub readme  { shift->rematein('readme') }
10126 #-> sub CPAN::Module::look ;
10127 sub look    { shift->rematein('look') }
10128 #-> sub CPAN::Module::cvs_import ;
10129 sub cvs_import { shift->rematein('cvs_import') }
10130 #-> sub CPAN::Module::get ;
10131 sub get     { shift->rematein('get',@_) }
10132 #-> sub CPAN::Module::make ;
10133 sub make    { shift->rematein('make') }
10134 #-> sub CPAN::Module::test ;
10135 sub test   {
10136     my $self = shift;
10137     # $self->{badtestcnt} ||= 0;
10138     $self->rematein('test',@_);
10139 }
10140
10141 #-> sub CPAN::Module::uptodate ;
10142 sub uptodate {
10143     my ($self) = @_;
10144     local ($_);
10145     my $inst = $self->inst_version or return undef;
10146     my $cpan = $self->cpan_version;
10147     local ($^W) = 0;
10148     CPAN::Version->vgt($cpan,$inst) and return 0;
10149     CPAN->debug(join("",
10150                      "returning uptodate. inst_file[",
10151                      $self->inst_file,
10152                      "cpan[$cpan] inst[$inst]")) if $CPAN::DEBUG;
10153     return 1;
10154 }
10155
10156 #-> sub CPAN::Module::install ;
10157 sub install {
10158     my($self) = @_;
10159     my($doit) = 0;
10160     if ($self->uptodate
10161         &&
10162         not exists $self->{force_update}
10163        ) {
10164         $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
10165                                          $self->id,
10166                                          $self->inst_version,
10167                                         ));
10168     } else {
10169         $doit = 1;
10170     }
10171     my $ro = $self->ro;
10172     if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
10173         $CPAN::Frontend->mywarn(qq{
10174 \n\n\n     ***WARNING***
10175      The module $self->{ID} has no active maintainer.\n\n\n
10176 });
10177         $CPAN::Frontend->mysleep(5);
10178     }
10179     $self->rematein('install') if $doit;
10180 }
10181 #-> sub CPAN::Module::clean ;
10182 sub clean  { shift->rematein('clean') }
10183
10184 #-> sub CPAN::Module::inst_file ;
10185 sub inst_file {
10186     my($self) = @_;
10187     $self->_file_in_path([@INC]);
10188 }
10189
10190 #-> sub CPAN::Module::available_file ;
10191 sub available_file {
10192     my($self) = @_;
10193     my $sep = $Config::Config{path_sep};
10194     my $perllib = $ENV{PERL5LIB};
10195     $perllib = $ENV{PERLLIB} unless defined $perllib;
10196     my @perllib = split(/$sep/,$perllib) if defined $perllib;
10197     $self->_file_in_path([@perllib,@INC]);
10198 }
10199
10200 #-> sub CPAN::Module::file_in_path ;
10201 sub _file_in_path {
10202     my($self,$path) = @_;
10203     my($dir,@packpath);
10204     @packpath = split /::/, $self->{ID};
10205     $packpath[-1] .= ".pm";
10206     if (@packpath == 1 && $packpath[0] eq "readline.pm") {
10207         unshift @packpath, "Term", "ReadLine"; # historical reasons
10208     }
10209     foreach $dir (@$path) {
10210         my $pmfile = File::Spec->catfile($dir,@packpath);
10211         if (-f $pmfile) {
10212             return $pmfile;
10213         }
10214     }
10215     return;
10216 }
10217
10218 #-> sub CPAN::Module::xs_file ;
10219 sub xs_file {
10220     my($self) = @_;
10221     my($dir,@packpath);
10222     @packpath = split /::/, $self->{ID};
10223     push @packpath, $packpath[-1];
10224     $packpath[-1] .= "." . $Config::Config{'dlext'};
10225     foreach $dir (@INC) {
10226         my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
10227         if (-f $xsfile) {
10228             return $xsfile;
10229         }
10230     }
10231     return;
10232 }
10233
10234 #-> sub CPAN::Module::inst_version ;
10235 sub inst_version {
10236     my($self) = @_;
10237     my $parsefile = $self->inst_file or return;
10238     my $have = $self->parse_version($parsefile);
10239     $have;
10240 }
10241
10242 #-> sub CPAN::Module::inst_version ;
10243 sub available_version {
10244     my($self) = @_;
10245     my $parsefile = $self->available_file or return;
10246     my $have = $self->parse_version($parsefile);
10247     $have;
10248 }
10249
10250 #-> sub CPAN::Module::parse_version ;
10251 sub parse_version {
10252     my($self,$parsefile) = @_;
10253     my $have = MM->parse_version($parsefile);
10254     $have = "undef" unless defined $have && length $have;
10255     $have =~ s/^ //; # since the %vd hack these two lines here are needed
10256     $have =~ s/ $//; # trailing whitespace happens all the time
10257
10258     $have = CPAN::Version->readable($have);
10259
10260     $have =~ s/\s*//g; # stringify to float around floating point issues
10261     $have; # no stringify needed, \s* above matches always
10262 }
10263
10264 #-> sub CPAN::Module::reports
10265 sub reports {
10266     my($self) = @_;
10267     $self->distribution->reports;
10268 }
10269
10270 package CPAN;
10271 use strict;
10272
10273 1;
10274
10275
10276 __END__
10277
10278 =head1 NAME
10279
10280 CPAN - query, download and build perl modules from CPAN sites
10281
10282 =head1 SYNOPSIS
10283
10284 Interactive mode:
10285
10286   perl -MCPAN -e shell
10287
10288 --or--
10289
10290   cpan
10291
10292 Basic commands:
10293
10294   # Modules:
10295
10296   cpan> install Acme::Meta                       # in the shell
10297
10298   CPAN::Shell->install("Acme::Meta");            # in perl
10299
10300   # Distributions:
10301
10302   cpan> install NWCLARK/Acme-Meta-0.02.tar.gz    # in the shell
10303
10304   CPAN::Shell->
10305     install("NWCLARK/Acme-Meta-0.02.tar.gz");    # in perl
10306
10307   # module objects:
10308
10309   $mo = CPAN::Shell->expandany($mod);
10310   $mo = CPAN::Shell->expand("Module",$mod);      # same thing
10311
10312   # distribution objects:
10313
10314   $do = CPAN::Shell->expand("Module",$mod)->distribution;
10315   $do = CPAN::Shell->expandany($distro);         # same thing
10316   $do = CPAN::Shell->expand("Distribution",
10317                             $distro);            # same thing
10318
10319 =head1 DESCRIPTION
10320
10321 The CPAN module automates or at least simplifies the make and install
10322 of perl modules and extensions. It includes some primitive searching
10323 capabilities and knows how to use Net::FTP or LWP or some external
10324 download clients to fetch the distributions from the net.
10325
10326 These are fetched from one or more of the mirrored CPAN (Comprehensive
10327 Perl Archive Network) sites and unpacked in a dedicated directory.
10328
10329 The CPAN module also supports the concept of named and versioned
10330 I<bundles> of modules. Bundles simplify the handling of sets of
10331 related modules. See Bundles below.
10332
10333 The package contains a session manager and a cache manager. The
10334 session manager keeps track of what has been fetched, built and
10335 installed in the current session. The cache manager keeps track of the
10336 disk space occupied by the make processes and deletes excess space
10337 according to a simple FIFO mechanism.
10338
10339 All methods provided are accessible in a programmer style and in an
10340 interactive shell style.
10341
10342 =head2 CPAN::shell([$prompt, $command]) Starting Interactive Mode
10343
10344 The interactive mode is entered by running
10345
10346     perl -MCPAN -e shell
10347
10348 or
10349
10350     cpan
10351
10352 which puts you into a readline interface. If C<Term::ReadKey> and
10353 either C<Term::ReadLine::Perl> or C<Term::ReadLine::Gnu> are installed
10354 it supports both history and command completion.
10355
10356 Once you are on the command line, type C<h> to get a one page help
10357 screen and the rest should be self-explanatory.
10358
10359 The function call C<shell> takes two optional arguments, one is the
10360 prompt, the second is the default initial command line (the latter
10361 only works if a real ReadLine interface module is installed).
10362
10363 The most common uses of the interactive modes are
10364
10365 =over 2
10366
10367 =item Searching for authors, bundles, distribution files and modules
10368
10369 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
10370 for each of the four categories and another, C<i> for any of the
10371 mentioned four. Each of the four entities is implemented as a class
10372 with slightly differing methods for displaying an object.
10373
10374 Arguments you pass to these commands are either strings exactly matching
10375 the identification string of an object or regular expressions that are
10376 then matched case-insensitively against various attributes of the
10377 objects. The parser recognizes a regular expression only if you
10378 enclose it between two slashes.
10379
10380 The principle is that the number of found objects influences how an
10381 item is displayed. If the search finds one item, the result is
10382 displayed with the rather verbose method C<as_string>, but if we find
10383 more than one, we display each object with the terse method
10384 C<as_glimpse>.
10385
10386 =item C<get>, C<make>, C<test>, C<install>, C<clean> modules or distributions
10387
10388 These commands take any number of arguments and investigate what is
10389 necessary to perform the action. If the argument is a distribution
10390 file name (recognized by embedded slashes), it is processed. If it is
10391 a module, CPAN determines the distribution file in which this module
10392 is included and processes that, following any dependencies named in
10393 the module's META.yml or Makefile.PL (this behavior is controlled by
10394 the configuration parameter C<prerequisites_policy>.)
10395
10396 C<get> downloads a distribution file and untars or unzips it, C<make>
10397 builds it, C<test> runs the test suite, and C<install> installs it.
10398
10399 Any C<make> or C<test> are run unconditionally. An
10400
10401   install <distribution_file>
10402
10403 also is run unconditionally. But for
10404
10405   install <module>
10406
10407 CPAN checks if an install is actually needed for it and prints
10408 I<module up to date> in the case that the distribution file containing
10409 the module doesn't need to be updated.
10410
10411 CPAN also keeps track of what it has done within the current session
10412 and doesn't try to build a package a second time regardless if it
10413 succeeded or not. It does not repeat a test run if the test
10414 has been run successfully before. Same for install runs.
10415
10416 The C<force> pragma may precede another command (currently: C<get>,
10417 C<make>, C<test>, or C<install>) and executes the command from scratch
10418 and tries to continue in case of some errors. See the section below on
10419 the C<force> and the C<fforce> pragma.
10420
10421 The C<notest> pragma may be used to skip the test part in the build
10422 process.
10423
10424 Example:
10425
10426     cpan> notest install Tk
10427
10428 A C<clean> command results in a
10429
10430   make clean
10431
10432 being executed within the distribution file's working directory.
10433
10434 =item C<readme>, C<perldoc>, C<look> module or distribution
10435
10436 C<readme> displays the README file of the associated distribution.
10437 C<Look> gets and untars (if not yet done) the distribution file,
10438 changes to the appropriate directory and opens a subshell process in
10439 that directory. C<perldoc> displays the pod documentation of the
10440 module in html or plain text format.
10441
10442 =item C<ls> author
10443
10444 =item C<ls> globbing_expression
10445
10446 The first form lists all distribution files in and below an author's
10447 CPAN directory as they are stored in the CHECKUMS files distributed on
10448 CPAN. The listing goes recursive into all subdirectories.
10449
10450 The second form allows to limit or expand the output with shell
10451 globbing as in the following examples:
10452
10453       ls JV/make*
10454       ls GSAR/*make*
10455       ls */*make*
10456
10457 The last example is very slow and outputs extra progress indicators
10458 that break the alignment of the result.
10459
10460 Note that globbing only lists directories explicitly asked for, for
10461 example FOO/* will not list FOO/bar/Acme-Sthg-n.nn.tar.gz. This may be
10462 regarded as a bug and may be changed in future versions.
10463
10464 =item C<failed>
10465
10466 The C<failed> command reports all distributions that failed on one of
10467 C<make>, C<test> or C<install> for some reason in the currently
10468 running shell session.
10469
10470 =item Persistence between sessions
10471
10472 If the C<YAML> or the C<YAML::Syck> module is installed a record of
10473 the internal state of all modules is written to disk after each step.
10474 The files contain a signature of the currently running perl version
10475 for later perusal.
10476
10477 If the configurations variable C<build_dir_reuse> is set to a true
10478 value, then CPAN.pm reads the collected YAML files. If the stored
10479 signature matches the currently running perl the stored state is
10480 loaded into memory such that effectively persistence between sessions
10481 is established.
10482
10483 =item The C<force> and the C<fforce> pragma
10484
10485 To speed things up in complex installation scenarios, CPAN.pm keeps
10486 track of what it has already done and refuses to do some things a
10487 second time. A C<get>, a C<make>, and an C<install> are not repeated.
10488 A C<test> is only repeated if the previous test was unsuccessful. The
10489 diagnostic message when CPAN.pm refuses to do something a second time
10490 is one of I<Has already been >C<unwrapped|made|tested successfully> or
10491 something similar. Another situation where CPAN refuses to act is an
10492 C<install> if the according C<test> was not successful.
10493
10494 In all these cases, the user can override the goatish behaviour by
10495 prepending the command with the word force, for example:
10496
10497   cpan> force get Foo
10498   cpan> force make AUTHOR/Bar-3.14.tar.gz
10499   cpan> force test Baz
10500   cpan> force install Acme::Meta
10501
10502 Each I<forced> command is executed with the according part of its
10503 memory erased.
10504
10505 The C<fforce> pragma is a variant that emulates a C<force get> which
10506 erases the entire memory followed by the action specified, effectively
10507 restarting the whole get/make/test/install procedure from scratch.
10508
10509 =item Lockfile
10510
10511 Interactive sessions maintain a lockfile, per default C<~/.cpan/.lock>.
10512 Batch jobs can run without a lockfile and do not disturb each other.
10513
10514 The shell offers to run in I<degraded mode> when another process is
10515 holding the lockfile. This is an experimental feature that is not yet
10516 tested very well. This second shell then does not write the history
10517 file, does not use the metadata file and has a different prompt.
10518
10519 =item Signals
10520
10521 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
10522 in the cpan-shell it is intended that you can press C<^C> anytime and
10523 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
10524 to clean up and leave the shell loop. You can emulate the effect of a
10525 SIGTERM by sending two consecutive SIGINTs, which usually means by
10526 pressing C<^C> twice.
10527
10528 CPAN.pm ignores a SIGPIPE. If the user sets C<inactivity_timeout>, a
10529 SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl
10530 Build.PL> subprocess.
10531
10532 =back
10533
10534 =head2 CPAN::Shell
10535
10536 The commands that are available in the shell interface are methods in
10537 the package CPAN::Shell. If you enter the shell command, all your
10538 input is split by the Text::ParseWords::shellwords() routine which
10539 acts like most shells do. The first word is being interpreted as the
10540 method to be called and the rest of the words are treated as arguments
10541 to this method. Continuation lines are supported if a line ends with a
10542 literal backslash.
10543
10544 =head2 autobundle
10545
10546 C<autobundle> writes a bundle file into the
10547 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
10548 a list of all modules that are both available from CPAN and currently
10549 installed within @INC. The name of the bundle file is based on the
10550 current date and a counter.
10551
10552 =head2 hosts
10553
10554 Note: this feature is still in alpha state and may change in future
10555 versions of CPAN.pm
10556
10557 This commands provides a statistical overview over recent download
10558 activities. The data for this is collected in the YAML file
10559 C<FTPstats.yml> in your C<cpan_home> directory. If no YAML module is
10560 configured or YAML not installed, then no stats are provided.
10561
10562 =head2 mkmyconfig
10563
10564 mkmyconfig() writes your own CPAN::MyConfig file into your ~/.cpan/
10565 directory so that you can save your own preferences instead of the
10566 system wide ones.
10567
10568 =head2 recent ***EXPERIMENTAL COMMAND***
10569
10570 The C<recent> command downloads a list of recent uploads to CPAN and
10571 displays them I<slowly>. While the command is running $SIG{INT} is
10572 defined to mean that the loop shall be left after having displayed the
10573 current item.
10574
10575 B<Note>: This command requires XML::LibXML installed.
10576
10577 B<Note>: This whole command currently is a bit klunky and will
10578 probably change in future versions of CPAN.pm but the general
10579 approach will likely stay.
10580
10581 B<Note>: See also L<smoke>
10582
10583 =head2 recompile
10584
10585 recompile() is a very special command in that it takes no argument and
10586 runs the make/test/install cycle with brute force over all installed
10587 dynamically loadable extensions (aka XS modules) with 'force' in
10588 effect. The primary purpose of this command is to finish a network
10589 installation. Imagine, you have a common source tree for two different
10590 architectures. You decide to do a completely independent fresh
10591 installation. You start on one architecture with the help of a Bundle
10592 file produced earlier. CPAN installs the whole Bundle for you, but
10593 when you try to repeat the job on the second architecture, CPAN
10594 responds with a C<"Foo up to date"> message for all modules. So you
10595 invoke CPAN's recompile on the second architecture and you're done.
10596
10597 Another popular use for C<recompile> is to act as a rescue in case your
10598 perl breaks binary compatibility. If one of the modules that CPAN uses
10599 is in turn depending on binary compatibility (so you cannot run CPAN
10600 commands), then you should try the CPAN::Nox module for recovery.
10601
10602 =head2 report Bundle|Distribution|Module
10603
10604 The C<report> command temporarily turns on the C<test_report> config
10605 variable, then runs the C<force test> command with the given
10606 arguments. The C<force> pragma is used to re-run the tests and repeat
10607 every step that might have failed before.
10608
10609 =head2 smoke ***EXPERIMENTAL COMMAND***
10610
10611 B<*** WARNING: this command downloads and executes software from CPAN to
10612 your computer of completely unknown status. You should never do
10613 this with your normal account and better have a dedicated well
10614 separated and secured machine to do this. ***>
10615
10616 The C<smoke> command takes the list of recent uploads to CPAN as
10617 provided by the C<recent> command and tests them all. While the
10618 command is running $SIG{INT} is defined to mean that the current item
10619 shall be skipped.
10620
10621 B<Note>: This whole command currently is a bit klunky and will
10622 probably change in future versions of CPAN.pm but the general
10623 approach will likely stay.
10624
10625 B<Note>: See also L<recent>
10626
10627 =head2 upgrade [Module|/Regex/]...
10628
10629 The C<upgrade> command first runs an C<r> command with the given
10630 arguments and then installs the newest versions of all modules that
10631 were listed by that.
10632
10633 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
10634
10635 Although it may be considered internal, the class hierarchy does matter
10636 for both users and programmer. CPAN.pm deals with above mentioned four
10637 classes, and all those classes share a set of methods. A classical
10638 single polymorphism is in effect. A metaclass object registers all
10639 objects of all kinds and indexes them with a string. The strings
10640 referencing objects have a separated namespace (well, not completely
10641 separated):
10642
10643          Namespace                         Class
10644
10645    words containing a "/" (slash)      Distribution
10646     words starting with Bundle::          Bundle
10647           everything else            Module or Author
10648
10649 Modules know their associated Distribution objects. They always refer
10650 to the most recent official release. Developers may mark their releases
10651 as unstable development versions (by inserting an underbar into the
10652 module version number which will also be reflected in the distribution
10653 name when you run 'make dist'), so the really hottest and newest
10654 distribution is not always the default.  If a module Foo circulates
10655 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
10656 way to install version 1.23 by saying
10657
10658     install Foo
10659
10660 This would install the complete distribution file (say
10661 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
10662 like to install version 1.23_90, you need to know where the
10663 distribution file resides on CPAN relative to the authors/id/
10664 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
10665 so you would have to say
10666
10667     install BAR/Foo-1.23_90.tar.gz
10668
10669 The first example will be driven by an object of the class
10670 CPAN::Module, the second by an object of class CPAN::Distribution.
10671
10672 =head2 Integrating local directories
10673
10674 Note: this feature is still in alpha state and may change in future
10675 versions of CPAN.pm
10676
10677 Distribution objects are normally distributions from the CPAN, but
10678 there is a slightly degenerate case for Distribution objects, too, of
10679 projects held on the local disk. These distribution objects have the
10680 same name as the local directory and end with a dot. A dot by itself
10681 is also allowed for the current directory at the time CPAN.pm was
10682 used. All actions such as C<make>, C<test>, and C<install> are applied
10683 directly to that directory. This gives the command C<cpan .> an
10684 interesting touch: while the normal mantra of installing a CPAN module
10685 without CPAN.pm is one of
10686
10687     perl Makefile.PL                 perl Build.PL
10688            ( go and get prerequisites )
10689     make                             ./Build
10690     make test                        ./Build test
10691     make install                     ./Build install
10692
10693 the command C<cpan .> does all of this at once. It figures out which
10694 of the two mantras is appropriate, fetches and installs all
10695 prerequisites, cares for them recursively and finally finishes the
10696 installation of the module in the current directory, be it a CPAN
10697 module or not.
10698
10699 The typical usage case is for private modules or working copies of
10700 projects from remote repositories on the local disk.
10701
10702 =head1 CONFIGURATION
10703
10704 When the CPAN module is used for the first time, a configuration
10705 dialog tries to determine a couple of site specific options. The
10706 result of the dialog is stored in a hash reference C< $CPAN::Config >
10707 in a file CPAN/Config.pm.
10708
10709 The default values defined in the CPAN/Config.pm file can be
10710 overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
10711 best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
10712 added to the search path of the CPAN module before the use() or
10713 require() statements. The mkmyconfig command writes this file for you.
10714
10715 The C<o conf> command has various bells and whistles:
10716
10717 =over
10718
10719 =item completion support
10720
10721 If you have a ReadLine module installed, you can hit TAB at any point
10722 of the commandline and C<o conf> will offer you completion for the
10723 built-in subcommands and/or config variable names.
10724
10725 =item displaying some help: o conf help
10726
10727 Displays a short help
10728
10729 =item displaying current values: o conf [KEY]
10730
10731 Displays the current value(s) for this config variable. Without KEY
10732 displays all subcommands and config variables.
10733
10734 Example:
10735
10736   o conf shell
10737
10738 If KEY starts and ends with a slash the string in between is
10739 interpreted as a regular expression and only keys matching this regex
10740 are displayed
10741
10742 Example:
10743
10744   o conf /color/
10745
10746 =item changing of scalar values: o conf KEY VALUE
10747
10748 Sets the config variable KEY to VALUE. The empty string can be
10749 specified as usual in shells, with C<''> or C<"">
10750
10751 Example:
10752
10753   o conf wget /usr/bin/wget
10754
10755 =item changing of list values: o conf KEY SHIFT|UNSHIFT|PUSH|POP|SPLICE|LIST
10756
10757 If a config variable name ends with C<list>, it is a list. C<o conf
10758 KEY shift> removes the first element of the list, C<o conf KEY pop>
10759 removes the last element of the list. C<o conf KEYS unshift LIST>
10760 prepends a list of values to the list, C<o conf KEYS push LIST>
10761 appends a list of valued to the list.
10762
10763 Likewise, C<o conf KEY splice LIST> passes the LIST to the according
10764 splice command.
10765
10766 Finally, any other list of arguments is taken as a new list value for
10767 the KEY variable discarding the previous value.
10768
10769 Examples:
10770
10771   o conf urllist unshift http://cpan.dev.local/CPAN
10772   o conf urllist splice 3 1
10773   o conf urllist http://cpan1.local http://cpan2.local ftp://ftp.perl.org
10774
10775 =item reverting to saved: o conf defaults
10776
10777 Reverts all config variables to the state in the saved config file.
10778
10779 =item saving the config: o conf commit
10780
10781 Saves all config variables to the current config file (CPAN/Config.pm
10782 or CPAN/MyConfig.pm that was loaded at start).
10783
10784 =back
10785
10786 The configuration dialog can be started any time later again by
10787 issuing the command C< o conf init > in the CPAN shell. A subset of
10788 the configuration dialog can be run by issuing C<o conf init WORD>
10789 where WORD is any valid config variable or a regular expression.
10790
10791 =head2 Config Variables
10792
10793 Currently the following keys in the hash reference $CPAN::Config are
10794 defined:
10795
10796   applypatch         path to external prg
10797   auto_commit        commit all changes to config variables to disk
10798   build_cache        size of cache for directories to build modules
10799   build_dir          locally accessible directory to build modules
10800   build_dir_reuse    boolean if distros in build_dir are persistent
10801   build_requires_install_policy
10802                      to install or not to install when a module is
10803                      only needed for building. yes|no|ask/yes|ask/no
10804   bzip2              path to external prg
10805   cache_metadata     use serializer to cache metadata
10806   commands_quote     prefered character to use for quoting external
10807                      commands when running them. Defaults to double
10808                      quote on Windows, single tick everywhere else;
10809                      can be set to space to disable quoting
10810   check_sigs         if signatures should be verified
10811   colorize_debug     Term::ANSIColor attributes for debugging output
10812   colorize_output    boolean if Term::ANSIColor should colorize output
10813   colorize_print     Term::ANSIColor attributes for normal output
10814   colorize_warn      Term::ANSIColor attributes for warnings
10815   commandnumber_in_prompt
10816                      boolean if you want to see current command number
10817   cpan_home          local directory reserved for this package
10818   curl               path to external prg
10819   dontload_hash      DEPRECATED
10820   dontload_list      arrayref: modules in the list will not be
10821                      loaded by the CPAN::has_inst() routine
10822   ftp                path to external prg
10823   ftp_passive        if set, the envariable FTP_PASSIVE is set for downloads
10824   ftp_proxy          proxy host for ftp requests
10825   getcwd             see below
10826   gpg                path to external prg
10827   gzip               location of external program gzip
10828   histfile           file to maintain history between sessions
10829   histsize           maximum number of lines to keep in histfile
10830   http_proxy         proxy host for http requests
10831   inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
10832                      after this many seconds inactivity. Set to 0 to
10833                      never break.
10834   index_expire       after this many days refetch index files
10835   inhibit_startup_message
10836                      if true, does not print the startup message
10837   keep_source_where  directory in which to keep the source (if we do)
10838   load_module_verbosity
10839                      report loading of optional modules used by CPAN.pm
10840   lynx               path to external prg
10841   make               location of external make program
10842   make_arg           arguments that should always be passed to 'make'
10843   make_install_make_command
10844                      the make command for running 'make install', for
10845                      example 'sudo make'
10846   make_install_arg   same as make_arg for 'make install'
10847   makepl_arg         arguments passed to 'perl Makefile.PL'
10848   mbuild_arg         arguments passed to './Build'
10849   mbuild_install_arg arguments passed to './Build install'
10850   mbuild_install_build_command
10851                      command to use instead of './Build' when we are
10852                      in the install stage, for example 'sudo ./Build'
10853   mbuildpl_arg       arguments passed to 'perl Build.PL'
10854   ncftp              path to external prg
10855   ncftpget           path to external prg
10856   no_proxy           don't proxy to these hosts/domains (comma separated list)
10857   pager              location of external program more (or any pager)
10858   password           your password if you CPAN server wants one
10859   patch              path to external prg
10860   prefer_installer   legal values are MB and EUMM: if a module comes
10861                      with both a Makefile.PL and a Build.PL, use the
10862                      former (EUMM) or the latter (MB); if the module
10863                      comes with only one of the two, that one will be
10864                      used in any case
10865   prerequisites_policy
10866                      what to do if you are missing module prerequisites
10867                      ('follow' automatically, 'ask' me, or 'ignore')
10868   prefs_dir          local directory to store per-distro build options
10869   proxy_user         username for accessing an authenticating proxy
10870   proxy_pass         password for accessing an authenticating proxy
10871   randomize_urllist  add some randomness to the sequence of the urllist
10872   scan_cache         controls scanning of cache ('atstart' or 'never')
10873   shell              your favorite shell
10874   show_unparsable_versions
10875                      boolean if r command tells which modules are versionless
10876   show_upload_date   boolean if commands should try to determine upload date
10877   show_zero_versions boolean if r command tells for which modules $version==0
10878   tar                location of external program tar
10879   tar_verbosity      verbosity level for the tar command
10880   term_is_latin      deprecated: if true Unicode is translated to ISO-8859-1
10881                      (and nonsense for characters outside latin range)
10882   term_ornaments     boolean to turn ReadLine ornamenting on/off
10883   test_report        email test reports (if CPAN::Reporter is installed)
10884   unzip              location of external program unzip
10885   urllist            arrayref to nearby CPAN sites (or equivalent locations)
10886   use_sqlite         use CPAN::SQLite for metadata storage (fast and lean)
10887   username           your username if you CPAN server wants one
10888   wait_list          arrayref to a wait server to try (See CPAN::WAIT)
10889   wget               path to external prg
10890   yaml_load_code     enable YAML code deserialisation
10891   yaml_module        which module to use to read/write YAML files
10892
10893 You can set and query each of these options interactively in the cpan
10894 shell with the C<o conf> or the C<o conf init> command as specified below.
10895
10896 =over 2
10897
10898 =item C<o conf E<lt>scalar optionE<gt>>
10899
10900 prints the current value of the I<scalar option>
10901
10902 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
10903
10904 Sets the value of the I<scalar option> to I<value>
10905
10906 =item C<o conf E<lt>list optionE<gt>>
10907
10908 prints the current value of the I<list option> in MakeMaker's
10909 neatvalue format.
10910
10911 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
10912
10913 shifts or pops the array in the I<list option> variable
10914
10915 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
10916
10917 works like the corresponding perl commands.
10918
10919 =item interactive editing: o conf init [MATCH|LIST]
10920
10921 Runs an interactive configuration dialog for matching variables.
10922 Without argument runs the dialog over all supported config variables.
10923 To specify a MATCH the argument must be enclosed by slashes.
10924
10925 Examples:
10926
10927   o conf init ftp_passive ftp_proxy
10928   o conf init /color/
10929
10930 Note: this method of setting config variables often provides more
10931 explanation about the functioning of a variable than the manpage.
10932
10933 =back
10934
10935 =head2 CPAN::anycwd($path): Note on config variable getcwd
10936
10937 CPAN.pm changes the current working directory often and needs to
10938 determine its own current working directory. Per default it uses
10939 Cwd::cwd but if this doesn't work on your system for some reason,
10940 alternatives can be configured according to the following table:
10941
10942 =over 4
10943
10944 =item cwd
10945
10946 Calls Cwd::cwd
10947
10948 =item getcwd
10949
10950 Calls Cwd::getcwd
10951
10952 =item fastcwd
10953
10954 Calls Cwd::fastcwd
10955
10956 =item backtickcwd
10957
10958 Calls the external command cwd.
10959
10960 =back
10961
10962 =head2 Note on the format of the urllist parameter
10963
10964 urllist parameters are URLs according to RFC 1738. We do a little
10965 guessing if your URL is not compliant, but if you have problems with
10966 C<file> URLs, please try the correct format. Either:
10967
10968     file://localhost/whatever/ftp/pub/CPAN/
10969
10970 or
10971
10972     file:///home/ftp/pub/CPAN/
10973
10974 =head2 The urllist parameter has CD-ROM support
10975
10976 The C<urllist> parameter of the configuration table contains a list of
10977 URLs that are to be used for downloading. If the list contains any
10978 C<file> URLs, CPAN always tries to get files from there first. This
10979 feature is disabled for index files. So the recommendation for the
10980 owner of a CD-ROM with CPAN contents is: include your local, possibly
10981 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
10982
10983   o conf urllist push file://localhost/CDROM/CPAN
10984
10985 CPAN.pm will then fetch the index files from one of the CPAN sites
10986 that come at the beginning of urllist. It will later check for each
10987 module if there is a local copy of the most recent version.
10988
10989 Another peculiarity of urllist is that the site that we could
10990 successfully fetch the last file from automatically gets a preference
10991 token and is tried as the first site for the next request. So if you
10992 add a new site at runtime it may happen that the previously preferred
10993 site will be tried another time. This means that if you want to disallow
10994 a site for the next transfer, it must be explicitly removed from
10995 urllist.
10996
10997 =head2 Maintaining the urllist parameter
10998
10999 If you have YAML.pm (or some other YAML module configured in
11000 C<yaml_module>) installed, CPAN.pm collects a few statistical data
11001 about recent downloads. You can view the statistics with the C<hosts>
11002 command or inspect them directly by looking into the C<FTPstats.yml>
11003 file in your C<cpan_home> directory.
11004
11005 To get some interesting statistics it is recommended to set the
11006 C<randomize_urllist> parameter that introduces some amount of
11007 randomness into the URL selection.
11008
11009 =head2 The C<requires> and C<build_requires> dependency declarations
11010
11011 Since CPAN.pm version 1.88_51 modules declared as C<build_requires> by
11012 a distribution are treated differently depending on the config
11013 variable C<build_requires_install_policy>. By setting
11014 C<build_requires_install_policy> to C<no> such a module is not being
11015 installed. It is only built and tested and then kept in the list of
11016 tested but uninstalled modules. As such it is available during the
11017 build of the dependent module by integrating the path to the
11018 C<blib/arch> and C<blib/lib> directories in the environment variable
11019 PERL5LIB. If C<build_requires_install_policy> is set ti C<yes>, then
11020 both modules declared as C<requires> and those declared as
11021 C<build_requires> are treated alike. By setting to C<ask/yes> or
11022 C<ask/no>, CPAN.pm asks the user and sets the default accordingly.
11023
11024 =head2 Configuration for individual distributions (I<Distroprefs>)
11025
11026 (B<Note:> This feature has been introduced in CPAN.pm 1.8854 and is
11027 still considered beta quality)
11028
11029 Distributions on the CPAN usually behave according to what we call the
11030 CPAN mantra. Or since the event of Module::Build we should talk about
11031 two mantras:
11032
11033     perl Makefile.PL     perl Build.PL
11034     make                 ./Build
11035     make test            ./Build test
11036     make install         ./Build install
11037
11038 But some modules cannot be built with this mantra. They try to get
11039 some extra data from the user via the environment, extra arguments or
11040 interactively thus disturbing the installation of large bundles like
11041 Phalanx100 or modules with many dependencies like Plagger.
11042
11043 The distroprefs system of C<CPAN.pm> addresses this problem by
11044 allowing the user to specify extra informations and recipes in YAML
11045 files to either
11046
11047 =over
11048
11049 =item
11050
11051 pass additional arguments to one of the four commands,
11052
11053 =item
11054
11055 set environment variables
11056
11057 =item
11058
11059 instantiate an Expect object that reads from the console, waits for
11060 some regular expressions and enters some answers
11061
11062 =item
11063
11064 temporarily override assorted C<CPAN.pm> configuration variables
11065
11066 =item
11067
11068 specify dependencies that the original maintainer forgot to specify
11069
11070 =item
11071
11072 disable the installation of an object altogether
11073
11074 =back
11075
11076 See the YAML and Data::Dumper files that come with the C<CPAN.pm>
11077 distribution in the C<distroprefs/> directory for examples.
11078
11079 =head2 Filenames
11080
11081 The YAML files themselves must have the C<.yml> extension, all other
11082 files are ignored (for two exceptions see I<Fallback Data::Dumper and
11083 Storable> below). The containing directory can be specified in
11084 C<CPAN.pm> in the C<prefs_dir> config variable. Try C<o conf init
11085 prefs_dir> in the CPAN shell to set and activate the distroprefs
11086 system.
11087
11088 Every YAML file may contain arbitrary documents according to the YAML
11089 specification and every single document is treated as an entity that
11090 can specify the treatment of a single distribution.
11091
11092 The names of the files can be picked freely, C<CPAN.pm> always reads
11093 all files (in alphabetical order) and takes the key C<match> (see
11094 below in I<Language Specs>) as a hashref containing match criteria
11095 that determine if the current distribution matches the YAML document
11096 or not.
11097
11098 =head2 Fallback Data::Dumper and Storable
11099
11100 If neither your configured C<yaml_module> nor YAML.pm is installed
11101 CPAN.pm falls back to using Data::Dumper and Storable and looks for
11102 files with the extensions C<.dd> or C<.st> in the C<prefs_dir>
11103 directory. These files are expected to contain one or more hashrefs.
11104 For Data::Dumper generated files, this is expected to be done with by
11105 defining C<$VAR1>, C<$VAR2>, etc. The YAML shell would produce these
11106 with the command
11107
11108     ysh < somefile.yml > somefile.dd
11109
11110 For Storable files the rule is that they must be constructed such that
11111 C<Storable::retrieve(file)> returns an array reference and the array
11112 elements represent one distropref object each. The conversion from
11113 YAML would look like so:
11114
11115     perl -MYAML=LoadFile -MStorable=nstore -e '
11116         @y=LoadFile(shift);
11117         nstore(\@y, shift)' somefile.yml somefile.st
11118
11119 In bootstrapping situations it is usually sufficient to translate only
11120 a few YAML files to Data::Dumper for the crucial modules like
11121 C<YAML::Syck>, C<YAML.pm> and C<Expect.pm>. If you prefer Storable
11122 over Data::Dumper, remember to pull out a Storable version that writes
11123 an older format than all the other Storable versions that will need to
11124 read them.
11125
11126 =head2 Blueprint
11127
11128 The following example contains all supported keywords and structures
11129 with the exception of C<eexpect> which can be used instead of
11130 C<expect>.
11131
11132   ---
11133   comment: "Demo"
11134   match:
11135     module: "Dancing::Queen"
11136     distribution: "^CHACHACHA/Dancing-"
11137     perl: "/usr/local/cariba-perl/bin/perl"
11138     perlconfig:
11139       archname: "freebsd"
11140   disabled: 1
11141   cpanconfig:
11142     make: gmake
11143   pl:
11144     args:
11145       - "--somearg=specialcase"
11146
11147     env: {}
11148
11149     expect:
11150       - "Which is your favorite fruit"
11151       - "apple\n"
11152
11153   make:
11154     args:
11155       - all
11156       - extra-all
11157
11158     env: {}
11159
11160     expect: []
11161
11162     commendline: "echo SKIPPING make"
11163
11164   test:
11165     args: []
11166
11167     env: {}
11168
11169     expect: []
11170
11171   install:
11172     args: []
11173
11174     env:
11175       WANT_TO_INSTALL: YES
11176
11177     expect:
11178       - "Do you really want to install"
11179       - "y\n"
11180
11181   patches:
11182     - "ABCDE/Fedcba-3.14-ABCDE-01.patch"
11183
11184   depends:
11185     configure_requires:
11186       LWP: 5.8
11187     build_requires:
11188       Test::Exception: 0.25
11189     requires:
11190       Spiffy: 0.30
11191
11192
11193 =head2 Language Specs
11194
11195 Every YAML document represents a single hash reference. The valid keys
11196 in this hash are as follows:
11197
11198 =over
11199
11200 =item comment [scalar]
11201
11202 A comment
11203
11204 =item cpanconfig [hash]
11205
11206 Temporarily override assorted C<CPAN.pm> configuration variables.
11207
11208 Supported are: C<build_requires_install_policy>, C<check_sigs>,
11209 C<make>, C<make_install_make_command>, C<prefer_installer>,
11210 C<test_report>. Please report as a bug when you need another one
11211 supported.
11212
11213 =item depends [hash] *** EXPERIMENTAL FEATURE ***
11214
11215 All three types, namely C<configure_requires>, C<build_requires>, and
11216 C<requires> are supported in the way specified in the META.yml
11217 specification. The current implementation I<merges> the specified
11218 dependencies with those declared by the package maintainer. In a
11219 future implementation this may be changed to override the original
11220 declaration.
11221
11222 =item disabled [boolean]
11223
11224 Specifies that this distribution shall not be processed at all.
11225
11226 =item goto [string]
11227
11228 The canonical name of a delegate distribution that shall be installed
11229 instead. Useful when a new version, although it tests OK itself,
11230 breaks something else or a developer release or a fork is already
11231 uploaded that is better than the last released version.
11232
11233 =item install [hash]
11234
11235 Processing instructions for the C<make install> or C<./Build install>
11236 phase of the CPAN mantra. See below under I<Processiong Instructions>.
11237
11238 =item make [hash]
11239
11240 Processing instructions for the C<make> or C<./Build> phase of the
11241 CPAN mantra. See below under I<Processiong Instructions>.
11242
11243 =item match [hash]
11244
11245 A hashref with one or more of the keys C<distribution>, C<modules>,
11246 C<perl>, and C<perlconfig> that specify if a document is targeted at a
11247 specific CPAN distribution or installation.
11248
11249 The corresponding values are interpreted as regular expressions. The
11250 C<distribution> related one will be matched against the canonical
11251 distribution name, e.g. "AUTHOR/Foo-Bar-3.14.tar.gz".
11252
11253 The C<module> related one will be matched against I<all> modules
11254 contained in the distribution until one module matches.
11255
11256 The C<perl> related one will be matched against C<$^X> (but with the
11257 absolute path).
11258
11259 The value associated with C<perlconfig> is itself a hashref that is
11260 matched against corresponding values in the C<%Config::Config> hash
11261 living in the C< Config.pm > module.
11262
11263 If more than one restriction of C<module>, C<distribution>, and
11264 C<perl> is specified, the results of the separately computed match
11265 values must all match. If this is the case then the hashref
11266 represented by the YAML document is returned as the preference
11267 structure for the current distribution.
11268
11269 =item patches [array]
11270
11271 An array of patches on CPAN or on the local disk to be applied in
11272 order via the external patch program. If the value for the C<-p>
11273 parameter is C<0> or C<1> is determined by reading the patch
11274 beforehand.
11275
11276 Note: if the C<applypatch> program is installed and C<CPAN::Config>
11277 knows about it B<and> a patch is written by the C<makepatch> program,
11278 then C<CPAN.pm> lets C<applypatch> apply the patch. Both C<makepatch>
11279 and C<applypatch> are available from CPAN in the C<JV/makepatch-*>
11280 distribution.
11281
11282 =item pl [hash]
11283
11284 Processing instructions for the C<perl Makefile.PL> or C<perl
11285 Build.PL> phase of the CPAN mantra. See below under I<Processiong
11286 Instructions>.
11287
11288 =item test [hash]
11289
11290 Processing instructions for the C<make test> or C<./Build test> phase
11291 of the CPAN mantra. See below under I<Processiong Instructions>.
11292
11293 =back
11294
11295 =head2 Processing Instructions
11296
11297 =over
11298
11299 =item args [array]
11300
11301 Arguments to be added to the command line
11302
11303 =item commandline
11304
11305 A full commandline that will be executed as it stands by a system
11306 call. During the execution the environment variable PERL will is set
11307 to $^X (but with an absolute path). If C<commandline> is specified,
11308 the content of C<args> is not used.
11309
11310 =item eexpect [hash]
11311
11312 Extended C<expect>. This is a hash reference with four allowed keys,
11313 C<mode>, C<timeout>, C<reuse>, and C<talk>.
11314
11315 C<mode> may have the values C<deterministic> for the case where all
11316 questions come in the order written down and C<anyorder> for the case
11317 where the questions may come in any order. The default mode is
11318 C<deterministic>.
11319
11320 C<timeout> denotes a timeout in seconds. Floating point timeouts are
11321 OK. In the case of a C<mode=deterministic> the timeout denotes the
11322 timeout per question, in the case of C<mode=anyorder> it denotes the
11323 timeout per byte received from the stream or questions.
11324
11325 C<talk> is a reference to an array that contains alternating questions
11326 and answers. Questions are regular expressions and answers are literal
11327 strings. The Expect module will then watch the stream coming from the
11328 execution of the external program (C<perl Makefile.PL>, C<perl
11329 Build.PL>, C<make>, etc.).
11330
11331 In the case of C<mode=deterministic> the CPAN.pm will inject the
11332 according answer as soon as the stream matches the regular expression.
11333
11334 In the case of C<mode=anyorder> CPAN.pm will answer a question as soon
11335 as the timeout is reached for the next byte in the input stream. In
11336 this mode you can use the C<reuse> parameter to decide what shall
11337 happen with a question-answer pair after it has been used. In the
11338 default case (reuse=0) it is removed from the array, so it cannot be
11339 used again accidentally. In this case, if you want to answer the
11340 question C<Do you really want to do that> several times, then it must
11341 be included in the array at least as often as you want this answer to
11342 be given. Setting the parameter C<reuse> to 1 makes this repetition
11343 unnecessary.
11344
11345 =item env [hash]
11346
11347 Environment variables to be set during the command
11348
11349 =item expect [array]
11350
11351 C<< expect: <array> >> is a short notation for
11352
11353   eexpect:
11354     mode: deterministic
11355     timeout: 15
11356     talk: <array>
11357
11358 =back
11359
11360 =head2 Schema verification with C<Kwalify>
11361
11362 If you have the C<Kwalify> module installed (which is part of the
11363 Bundle::CPANxxl), then all your distroprefs files are checked for
11364 syntactical correctness.
11365
11366 =head2 Example Distroprefs Files
11367
11368 C<CPAN.pm> comes with a collection of example YAML files. Note that these
11369 are really just examples and should not be used without care because
11370 they cannot fit everybody's purpose. After all the authors of the
11371 packages that ask questions had a need to ask, so you should watch
11372 their questions and adjust the examples to your environment and your
11373 needs. You have beend warned:-)
11374
11375 =head1 PROGRAMMER'S INTERFACE
11376
11377 If you do not enter the shell, the available shell commands are both
11378 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
11379 functions in the calling package (C<install(...)>).  Before calling low-level
11380 commands it makes sense to initialize components of CPAN you need, e.g.:
11381
11382   CPAN::HandleConfig->load;
11383   CPAN::Shell::setup_output;
11384   CPAN::Index->reload;
11385
11386 High-level commands do such initializations automatically.
11387
11388 There's currently only one class that has a stable interface -
11389 CPAN::Shell. All commands that are available in the CPAN shell are
11390 methods of the class CPAN::Shell. Each of the commands that produce
11391 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
11392 the IDs of all modules within the list.
11393
11394 =over 2
11395
11396 =item expand($type,@things)
11397
11398 The IDs of all objects available within a program are strings that can
11399 be expanded to the corresponding real objects with the
11400 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
11401 list of CPAN::Module objects according to the C<@things> arguments
11402 given. In scalar context it only returns the first element of the
11403 list.
11404
11405 =item expandany(@things)
11406
11407 Like expand, but returns objects of the appropriate type, i.e.
11408 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
11409 CPAN::Distribution objects for distributions. Note: it does not expand
11410 to CPAN::Author objects.
11411
11412 =item Programming Examples
11413
11414 This enables the programmer to do operations that combine
11415 functionalities that are available in the shell.
11416
11417     # install everything that is outdated on my disk:
11418     perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
11419
11420     # install my favorite programs if necessary:
11421     for $mod (qw(Net::FTP Digest::SHA Data::Dumper)) {
11422         CPAN::Shell->install($mod);
11423     }
11424
11425     # list all modules on my disk that have no VERSION number
11426     for $mod (CPAN::Shell->expand("Module","/./")) {
11427         next unless $mod->inst_file;
11428         # MakeMaker convention for undefined $VERSION:
11429         next unless $mod->inst_version eq "undef";
11430         print "No VERSION in ", $mod->id, "\n";
11431     }
11432
11433     # find out which distribution on CPAN contains a module:
11434     print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
11435
11436 Or if you want to write a cronjob to watch The CPAN, you could list
11437 all modules that need updating. First a quick and dirty way:
11438
11439     perl -e 'use CPAN; CPAN::Shell->r;'
11440
11441 If you don't want to get any output in the case that all modules are
11442 up to date, you can parse the output of above command for the regular
11443 expression //modules are up to date// and decide to mail the output
11444 only if it doesn't match. Ick?
11445
11446 If you prefer to do it more in a programmer style in one single
11447 process, maybe something like this suits you better:
11448
11449   # list all modules on my disk that have newer versions on CPAN
11450   for $mod (CPAN::Shell->expand("Module","/./")) {
11451     next unless $mod->inst_file;
11452     next if $mod->uptodate;
11453     printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
11454         $mod->id, $mod->inst_version, $mod->cpan_version;
11455   }
11456
11457 If that gives you too much output every day, you maybe only want to
11458 watch for three modules. You can write
11459
11460   for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")) {
11461
11462 as the first line instead. Or you can combine some of the above
11463 tricks:
11464
11465   # watch only for a new mod_perl module
11466   $mod = CPAN::Shell->expand("Module","mod_perl");
11467   exit if $mod->uptodate;
11468   # new mod_perl arrived, let me know all update recommendations
11469   CPAN::Shell->r;
11470
11471 =back
11472
11473 =head2 Methods in the other Classes
11474
11475 =over 4
11476
11477 =item CPAN::Author::as_glimpse()
11478
11479 Returns a one-line description of the author
11480
11481 =item CPAN::Author::as_string()
11482
11483 Returns a multi-line description of the author
11484
11485 =item CPAN::Author::email()
11486
11487 Returns the author's email address
11488
11489 =item CPAN::Author::fullname()
11490
11491 Returns the author's name
11492
11493 =item CPAN::Author::name()
11494
11495 An alias for fullname
11496
11497 =item CPAN::Bundle::as_glimpse()
11498
11499 Returns a one-line description of the bundle
11500
11501 =item CPAN::Bundle::as_string()
11502
11503 Returns a multi-line description of the bundle
11504
11505 =item CPAN::Bundle::clean()
11506
11507 Recursively runs the C<clean> method on all items contained in the bundle.
11508
11509 =item CPAN::Bundle::contains()
11510
11511 Returns a list of objects' IDs contained in a bundle. The associated
11512 objects may be bundles, modules or distributions.
11513
11514 =item CPAN::Bundle::force($method,@args)
11515
11516 Forces CPAN to perform a task that it normally would have refused to
11517 do. Force takes as arguments a method name to be called and any number
11518 of additional arguments that should be passed to the called method.
11519 The internals of the object get the needed changes so that CPAN.pm
11520 does not refuse to take the action. The C<force> is passed recursively
11521 to all contained objects. See also the section above on the C<force>
11522 and the C<fforce> pragma.
11523
11524 =item CPAN::Bundle::get()
11525
11526 Recursively runs the C<get> method on all items contained in the bundle
11527
11528 =item CPAN::Bundle::inst_file()
11529
11530 Returns the highest installed version of the bundle in either @INC or
11531 C<$CPAN::Config->{cpan_home}>. Note that this is different from
11532 CPAN::Module::inst_file.
11533
11534 =item CPAN::Bundle::inst_version()
11535
11536 Like CPAN::Bundle::inst_file, but returns the $VERSION
11537
11538 =item CPAN::Bundle::uptodate()
11539
11540 Returns 1 if the bundle itself and all its members are uptodate.
11541
11542 =item CPAN::Bundle::install()
11543
11544 Recursively runs the C<install> method on all items contained in the bundle
11545
11546 =item CPAN::Bundle::make()
11547
11548 Recursively runs the C<make> method on all items contained in the bundle
11549
11550 =item CPAN::Bundle::readme()
11551
11552 Recursively runs the C<readme> method on all items contained in the bundle
11553
11554 =item CPAN::Bundle::test()
11555
11556 Recursively runs the C<test> method on all items contained in the bundle
11557
11558 =item CPAN::Distribution::as_glimpse()
11559
11560 Returns a one-line description of the distribution
11561
11562 =item CPAN::Distribution::as_string()
11563
11564 Returns a multi-line description of the distribution
11565
11566 =item CPAN::Distribution::author
11567
11568 Returns the CPAN::Author object of the maintainer who uploaded this
11569 distribution
11570
11571 =item CPAN::Distribution::pretty_id()
11572
11573 Returns a string of the form "AUTHORID/TARBALL", where AUTHORID is the
11574 author's PAUSE ID and TARBALL is the distribution filename.
11575
11576 =item CPAN::Distribution::base_id()
11577
11578 Returns the distribution filename without any archive suffix.  E.g
11579 "Foo-Bar-0.01"
11580
11581 =item CPAN::Distribution::clean()
11582
11583 Changes to the directory where the distribution has been unpacked and
11584 runs C<make clean> there.
11585
11586 =item CPAN::Distribution::containsmods()
11587
11588 Returns a list of IDs of modules contained in a distribution file.
11589 Only works for distributions listed in the 02packages.details.txt.gz
11590 file. This typically means that only the most recent version of a
11591 distribution is covered.
11592
11593 =item CPAN::Distribution::cvs_import()
11594
11595 Changes to the directory where the distribution has been unpacked and
11596 runs something like
11597
11598     cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
11599
11600 there.
11601
11602 =item CPAN::Distribution::dir()
11603
11604 Returns the directory into which this distribution has been unpacked.
11605
11606 =item CPAN::Distribution::force($method,@args)
11607
11608 Forces CPAN to perform a task that it normally would have refused to
11609 do. Force takes as arguments a method name to be called and any number
11610 of additional arguments that should be passed to the called method.
11611 The internals of the object get the needed changes so that CPAN.pm
11612 does not refuse to take the action. See also the section above on the
11613 C<force> and the C<fforce> pragma.
11614
11615 =item CPAN::Distribution::get()
11616
11617 Downloads the distribution from CPAN and unpacks it. Does nothing if
11618 the distribution has already been downloaded and unpacked within the
11619 current session.
11620
11621 =item CPAN::Distribution::install()
11622
11623 Changes to the directory where the distribution has been unpacked and
11624 runs the external command C<make install> there. If C<make> has not
11625 yet been run, it will be run first. A C<make test> will be issued in
11626 any case and if this fails, the install will be canceled. The
11627 cancellation can be avoided by letting C<force> run the C<install> for
11628 you.
11629
11630 This install method has only the power to install the distribution if
11631 there are no dependencies in the way. To install an object and all of
11632 its dependencies, use CPAN::Shell->install.
11633
11634 Note that install() gives no meaningful return value. See uptodate().
11635
11636 =item CPAN::Distribution::install_tested()
11637
11638 Install all the distributions that have been tested sucessfully but
11639 not yet installed. See also C<is_tested>.
11640
11641 =item CPAN::Distribution::isa_perl()
11642
11643 Returns 1 if this distribution file seems to be a perl distribution.
11644 Normally this is derived from the file name only, but the index from
11645 CPAN can contain a hint to achieve a return value of true for other
11646 filenames too.
11647
11648 =item CPAN::Distribution::is_tested()
11649
11650 List all the distributions that have been tested sucessfully but not
11651 yet installed. See also C<install_tested>.
11652
11653 =item CPAN::Distribution::look()
11654
11655 Changes to the directory where the distribution has been unpacked and
11656 opens a subshell there. Exiting the subshell returns.
11657
11658 =item CPAN::Distribution::make()
11659
11660 First runs the C<get> method to make sure the distribution is
11661 downloaded and unpacked. Changes to the directory where the
11662 distribution has been unpacked and runs the external commands C<perl
11663 Makefile.PL> or C<perl Build.PL> and C<make> there.
11664
11665 =item CPAN::Distribution::perldoc()
11666
11667 Downloads the pod documentation of the file associated with a
11668 distribution (in html format) and runs it through the external
11669 command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
11670 isn't available, it converts it to plain text with external
11671 command html2text and runs it through the pager specified
11672 in C<$CPAN::Config->{pager}>
11673
11674 =item CPAN::Distribution::prefs()
11675
11676 Returns the hash reference from the first matching YAML file that the
11677 user has deposited in the C<prefs_dir/> directory. The first
11678 succeeding match wins. The files in the C<prefs_dir/> are processed
11679 alphabetically and the canonical distroname (e.g.
11680 AUTHOR/Foo-Bar-3.14.tar.gz) is matched against the regular expressions
11681 stored in the $root->{match}{distribution} attribute value.
11682 Additionally all module names contained in a distribution are matched
11683 agains the regular expressions in the $root->{match}{module} attribute
11684 value. The two match values are ANDed together. Each of the two
11685 attributes are optional.
11686
11687 =item CPAN::Distribution::prereq_pm()
11688
11689 Returns the hash reference that has been announced by a distribution
11690 as the the C<requires> and C<build_requires> elements. These can be
11691 declared either by the C<META.yml> (if authoritative) or can be
11692 deposited after the run of C<Build.PL> in the file C<./_build/prereqs>
11693 or after the run of C<Makfile.PL> written as the C<PREREQ_PM> hash in
11694 a comment in the produced C<Makefile>. I<Note>: this method only works
11695 after an attempt has been made to C<make> the distribution. Returns
11696 undef otherwise.
11697
11698 =item CPAN::Distribution::readme()
11699
11700 Downloads the README file associated with a distribution and runs it
11701 through the pager specified in C<$CPAN::Config->{pager}>.
11702
11703 =item CPAN::Distribution::reports()
11704
11705 Downloads report data for this distribution from cpantesters.perl.org
11706 and displays a subset of them.
11707
11708 =item CPAN::Distribution::read_yaml()
11709
11710 Returns the content of the META.yml of this distro as a hashref. Note:
11711 works only after an attempt has been made to C<make> the distribution.
11712 Returns undef otherwise. Also returns undef if the content of META.yml
11713 is not authoritative. (The rules about what exactly makes the content
11714 authoritative are still in flux.)
11715
11716 =item CPAN::Distribution::test()
11717
11718 Changes to the directory where the distribution has been unpacked and
11719 runs C<make test> there.
11720
11721 =item CPAN::Distribution::uptodate()
11722
11723 Returns 1 if all the modules contained in the distribution are
11724 uptodate. Relies on containsmods.
11725
11726 =item CPAN::Index::force_reload()
11727
11728 Forces a reload of all indices.
11729
11730 =item CPAN::Index::reload()
11731
11732 Reloads all indices if they have not been read for more than
11733 C<$CPAN::Config->{index_expire}> days.
11734
11735 =item CPAN::InfoObj::dump()
11736
11737 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
11738 inherit this method. It prints the data structure associated with an
11739 object. Useful for debugging. Note: the data structure is considered
11740 internal and thus subject to change without notice.
11741
11742 =item CPAN::Module::as_glimpse()
11743
11744 Returns a one-line description of the module in four columns: The
11745 first column contains the word C<Module>, the second column consists
11746 of one character: an equals sign if this module is already installed
11747 and uptodate, a less-than sign if this module is installed but can be
11748 upgraded, and a space if the module is not installed. The third column
11749 is the name of the module and the fourth column gives maintainer or
11750 distribution information.
11751
11752 =item CPAN::Module::as_string()
11753
11754 Returns a multi-line description of the module
11755
11756 =item CPAN::Module::clean()
11757
11758 Runs a clean on the distribution associated with this module.
11759
11760 =item CPAN::Module::cpan_file()
11761
11762 Returns the filename on CPAN that is associated with the module.
11763
11764 =item CPAN::Module::cpan_version()
11765
11766 Returns the latest version of this module available on CPAN.
11767
11768 =item CPAN::Module::cvs_import()
11769
11770 Runs a cvs_import on the distribution associated with this module.
11771
11772 =item CPAN::Module::description()
11773
11774 Returns a 44 character description of this module. Only available for
11775 modules listed in The Module List (CPAN/modules/00modlist.long.html
11776 or 00modlist.long.txt.gz)
11777
11778 =item CPAN::Module::distribution()
11779
11780 Returns the CPAN::Distribution object that contains the current
11781 version of this module.
11782
11783 =item CPAN::Module::dslip_status()
11784
11785 Returns a hash reference. The keys of the hash are the letters C<D>,
11786 C<S>, C<L>, C<I>, and <P>, for development status, support level,
11787 language, interface and public licence respectively. The data for the
11788 DSLIP status are collected by pause.perl.org when authors register
11789 their namespaces. The values of the 5 hash elements are one-character
11790 words whose meaning is described in the table below. There are also 5
11791 hash elements C<DV>, C<SV>, C<LV>, C<IV>, and <PV> that carry a more
11792 verbose value of the 5 status variables.
11793
11794 Where the 'DSLIP' characters have the following meanings:
11795
11796   D - Development Stage  (Note: *NO IMPLIED TIMESCALES*):
11797     i   - Idea, listed to gain consensus or as a placeholder
11798     c   - under construction but pre-alpha (not yet released)
11799     a/b - Alpha/Beta testing
11800     R   - Released
11801     M   - Mature (no rigorous definition)
11802     S   - Standard, supplied with Perl 5
11803
11804   S - Support Level:
11805     m   - Mailing-list
11806     d   - Developer
11807     u   - Usenet newsgroup comp.lang.perl.modules
11808     n   - None known, try comp.lang.perl.modules
11809     a   - abandoned; volunteers welcome to take over maintainance
11810
11811   L - Language Used:
11812     p   - Perl-only, no compiler needed, should be platform independent
11813     c   - C and perl, a C compiler will be needed
11814     h   - Hybrid, written in perl with optional C code, no compiler needed
11815     +   - C++ and perl, a C++ compiler will be needed
11816     o   - perl and another language other than C or C++
11817
11818   I - Interface Style
11819     f   - plain Functions, no references used
11820     h   - hybrid, object and function interfaces available
11821     n   - no interface at all (huh?)
11822     r   - some use of unblessed References or ties
11823     O   - Object oriented using blessed references and/or inheritance
11824
11825   P - Public License
11826     p   - Standard-Perl: user may choose between GPL and Artistic
11827     g   - GPL: GNU General Public License
11828     l   - LGPL: "GNU Lesser General Public License" (previously known as
11829           "GNU Library General Public License")
11830     b   - BSD: The BSD License
11831     a   - Artistic license alone
11832     2   - Artistic license 2.0 or later
11833     o   - open source: appoved by www.opensource.org
11834     d   - allows distribution without restrictions
11835     r   - restricted distribtion
11836     n   - no license at all
11837
11838 =item CPAN::Module::force($method,@args)
11839
11840 Forces CPAN to perform a task that it normally would have refused to
11841 do. Force takes as arguments a method name to be called and any number
11842 of additional arguments that should be passed to the called method.
11843 The internals of the object get the needed changes so that CPAN.pm
11844 does not refuse to take the action. See also the section above on the
11845 C<force> and the C<fforce> pragma.
11846
11847 =item CPAN::Module::get()
11848
11849 Runs a get on the distribution associated with this module.
11850
11851 =item CPAN::Module::inst_file()
11852
11853 Returns the filename of the module found in @INC. The first file found
11854 is reported just like perl itself stops searching @INC when it finds a
11855 module.
11856
11857 =item CPAN::Module::available_file()
11858
11859 Returns the filename of the module found in PERL5LIB or @INC. The
11860 first file found is reported. The advantage of this method over
11861 C<inst_file> is that modules that have been tested but not yet
11862 installed are included because PERL5LIB keeps track of tested modules.
11863
11864 =item CPAN::Module::inst_version()
11865
11866 Returns the version number of the installed module in readable format.
11867
11868 =item CPAN::Module::available_version()
11869
11870 Returns the version number of the available module in readable format.
11871
11872 =item CPAN::Module::install()
11873
11874 Runs an C<install> on the distribution associated with this module.
11875
11876 =item CPAN::Module::look()
11877
11878 Changes to the directory where the distribution associated with this
11879 module has been unpacked and opens a subshell there. Exiting the
11880 subshell returns.
11881
11882 =item CPAN::Module::make()
11883
11884 Runs a C<make> on the distribution associated with this module.
11885
11886 =item CPAN::Module::manpage_headline()
11887
11888 If module is installed, peeks into the module's manpage, reads the
11889 headline and returns it. Moreover, if the module has been downloaded
11890 within this session, does the equivalent on the downloaded module even
11891 if it is not installed.
11892
11893 =item CPAN::Module::perldoc()
11894
11895 Runs a C<perldoc> on this module.
11896
11897 =item CPAN::Module::readme()
11898
11899 Runs a C<readme> on the distribution associated with this module.
11900
11901 =item CPAN::Module::reports()
11902
11903 Calls the reports() method on the associated distribution object.
11904
11905 =item CPAN::Module::test()
11906
11907 Runs a C<test> on the distribution associated with this module.
11908
11909 =item CPAN::Module::uptodate()
11910
11911 Returns 1 if the module is installed and up-to-date.
11912
11913 =item CPAN::Module::userid()
11914
11915 Returns the author's ID of the module.
11916
11917 =back
11918
11919 =head2 Cache Manager
11920
11921 Currently the cache manager only keeps track of the build directory
11922 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
11923 deletes complete directories below C<build_dir> as soon as the size of
11924 all directories there gets bigger than $CPAN::Config->{build_cache}
11925 (in MB). The contents of this cache may be used for later
11926 re-installations that you intend to do manually, but will never be
11927 trusted by CPAN itself. This is due to the fact that the user might
11928 use these directories for building modules on different architectures.
11929
11930 There is another directory ($CPAN::Config->{keep_source_where}) where
11931 the original distribution files are kept. This directory is not
11932 covered by the cache manager and must be controlled by the user. If
11933 you choose to have the same directory as build_dir and as
11934 keep_source_where directory, then your sources will be deleted with
11935 the same fifo mechanism.
11936
11937 =head2 Bundles
11938
11939 A bundle is just a perl module in the namespace Bundle:: that does not
11940 define any functions or methods. It usually only contains documentation.
11941
11942 It starts like a perl module with a package declaration and a $VERSION
11943 variable. After that the pod section looks like any other pod with the
11944 only difference being that I<one special pod section> exists starting with
11945 (verbatim):
11946
11947     =head1 CONTENTS
11948
11949 In this pod section each line obeys the format
11950
11951         Module_Name [Version_String] [- optional text]
11952
11953 The only required part is the first field, the name of a module
11954 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
11955 of the line is optional. The comment part is delimited by a dash just
11956 as in the man page header.
11957
11958 The distribution of a bundle should follow the same convention as
11959 other distributions.
11960
11961 Bundles are treated specially in the CPAN package. If you say 'install
11962 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
11963 the modules in the CONTENTS section of the pod. You can install your
11964 own Bundles locally by placing a conformant Bundle file somewhere into
11965 your @INC path. The autobundle() command which is available in the
11966 shell interface does that for you by including all currently installed
11967 modules in a snapshot bundle file.
11968
11969 =head1 PREREQUISITES
11970
11971 If you have a local mirror of CPAN and can access all files with
11972 "file:" URLs, then you only need a perl better than perl5.003 to run
11973 this module. Otherwise Net::FTP is strongly recommended. LWP may be
11974 required for non-UNIX systems or if your nearest CPAN site is
11975 associated with a URL that is not C<ftp:>.
11976
11977 If you have neither Net::FTP nor LWP, there is a fallback mechanism
11978 implemented for an external ftp command or for an external lynx
11979 command.
11980
11981 =head1 UTILITIES
11982
11983 =head2 Finding packages and VERSION
11984
11985 This module presumes that all packages on CPAN
11986
11987 =over 2
11988
11989 =item *
11990
11991 declare their $VERSION variable in an easy to parse manner. This
11992 prerequisite can hardly be relaxed because it consumes far too much
11993 memory to load all packages into the running program just to determine
11994 the $VERSION variable. Currently all programs that are dealing with
11995 version use something like this
11996
11997     perl -MExtUtils::MakeMaker -le \
11998         'print MM->parse_version(shift)' filename
11999
12000 If you are author of a package and wonder if your $VERSION can be
12001 parsed, please try the above method.
12002
12003 =item *
12004
12005 come as compressed or gzipped tarfiles or as zip files and contain a
12006 C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
12007 without much enthusiasm).
12008
12009 =back
12010
12011 =head2 Debugging
12012
12013 The debugging of this module is a bit complex, because we have
12014 interferences of the software producing the indices on CPAN, of the
12015 mirroring process on CPAN, of packaging, of configuration, of
12016 synchronicity, and of bugs within CPAN.pm.
12017
12018 For debugging the code of CPAN.pm itself in interactive mode some more
12019 or less useful debugging aid can be turned on for most packages within
12020 CPAN.pm with one of
12021
12022 =over 2
12023
12024 =item o debug package...
12025
12026 sets debug mode for packages.
12027
12028 =item o debug -package...
12029
12030 unsets debug mode for packages.
12031
12032 =item o debug all
12033
12034 turns debugging on for all packages.
12035
12036 =item o debug number
12037
12038 =back
12039
12040 which sets the debugging packages directly. Note that C<o debug 0>
12041 turns debugging off.
12042
12043 What seems quite a successful strategy is the combination of C<reload
12044 cpan> and the debugging switches. Add a new debug statement while
12045 running in the shell and then issue a C<reload cpan> and see the new
12046 debugging messages immediately without losing the current context.
12047
12048 C<o debug> without an argument lists the valid package names and the
12049 current set of packages in debugging mode. C<o debug> has built-in
12050 completion support.
12051
12052 For debugging of CPAN data there is the C<dump> command which takes
12053 the same arguments as make/test/install and outputs each object's
12054 Data::Dumper dump. If an argument looks like a perl variable and
12055 contains one of C<$>, C<@> or C<%>, it is eval()ed and fed to
12056 Data::Dumper directly.
12057
12058 =head2 Floppy, Zip, Offline Mode
12059
12060 CPAN.pm works nicely without network too. If you maintain machines
12061 that are not networked at all, you should consider working with file:
12062 URLs. Of course, you have to collect your modules somewhere first. So
12063 you might use CPAN.pm to put together all you need on a networked
12064 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
12065 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
12066 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
12067 with this floppy. See also below the paragraph about CD-ROM support.
12068
12069 =head2 Basic Utilities for Programmers
12070
12071 =over 2
12072
12073 =item has_inst($module)
12074
12075 Returns true if the module is installed. Used to load all modules into
12076 the running CPAN.pm which are considered optional. The config variable
12077 C<dontload_list> can be used to intercept the C<has_inst()> call such
12078 that an optional module is not loaded despite being available. For
12079 example the following command will prevent that C<YAML.pm> is being
12080 loaded:
12081
12082     cpan> o conf dontload_list push YAML
12083
12084 See the source for details.
12085
12086 =item has_usable($module)
12087
12088 Returns true if the module is installed and is in a usable state. Only
12089 useful for a handful of modules that are used internally. See the
12090 source for details.
12091
12092 =item instance($module)
12093
12094 The constructor for all the singletons used to represent modules,
12095 distributions, authors and bundles. If the object already exists, this
12096 method returns the object, otherwise it calls the constructor.
12097
12098 =back
12099
12100 =head1 SECURITY
12101
12102 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
12103 install foreign, unmasked, unsigned code on your machine. We compare
12104 to a checksum that comes from the net just as the distribution file
12105 itself. But we try to make it easy to add security on demand:
12106
12107 =head2 Cryptographically signed modules
12108
12109 Since release 1.77 CPAN.pm has been able to verify cryptographically
12110 signed module distributions using Module::Signature.  The CPAN modules
12111 can be signed by their authors, thus giving more security.  The simple
12112 unsigned MD5 checksums that were used before by CPAN protect mainly
12113 against accidental file corruption.
12114
12115 You will need to have Module::Signature installed, which in turn
12116 requires that you have at least one of Crypt::OpenPGP module or the
12117 command-line F<gpg> tool installed.
12118
12119 You will also need to be able to connect over the Internet to the public
12120 keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
12121
12122 The configuration parameter check_sigs is there to turn signature
12123 checking on or off.
12124
12125 =head1 EXPORT
12126
12127 Most functions in package CPAN are exported per default. The reason
12128 for this is that the primary use is intended for the cpan shell or for
12129 one-liners.
12130
12131 =head1 ENVIRONMENT
12132
12133 When the CPAN shell enters a subshell via the look command, it sets
12134 the environment CPAN_SHELL_LEVEL to 1 or increments it if it is
12135 already set.
12136
12137 When CPAN runs, it sets the environment variable PERL5_CPAN_IS_RUNNING
12138 to the ID of the running process. It also sets
12139 PERL5_CPANPLUS_IS_RUNNING to prevent runaway processes which could
12140 happen with older versions of Module::Install.
12141
12142 When running C<perl Makefile.PL>, the environment variable
12143 C<PERL5_CPAN_IS_EXECUTING> is set to the full path of the
12144 C<Makefile.PL> that is being executed. This prevents runaway processes
12145 with newer versions of Module::Install.
12146
12147 When the config variable ftp_passive is set, all downloads will be run
12148 with the environment variable FTP_PASSIVE set to this value. This is
12149 in general a good idea as it influences both Net::FTP and LWP based
12150 connections. The same effect can be achieved by starting the cpan
12151 shell with this environment variable set. For Net::FTP alone, one can
12152 also always set passive mode by running libnetcfg.
12153
12154 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
12155
12156 Populating a freshly installed perl with my favorite modules is pretty
12157 easy if you maintain a private bundle definition file. To get a useful
12158 blueprint of a bundle definition file, the command autobundle can be used
12159 on the CPAN shell command line. This command writes a bundle definition
12160 file for all modules that are installed for the currently running perl
12161 interpreter. It's recommended to run this command only once and from then
12162 on maintain the file manually under a private name, say
12163 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
12164
12165     cpan> install Bundle::my_bundle
12166
12167 then answer a few questions and then go out for a coffee.
12168
12169 Maintaining a bundle definition file means keeping track of two
12170 things: dependencies and interactivity. CPAN.pm sometimes fails on
12171 calculating dependencies because not all modules define all MakeMaker
12172 attributes correctly, so a bundle definition file should specify
12173 prerequisites as early as possible. On the other hand, it's a bit
12174 annoying that many distributions need some interactive configuring. So
12175 what I try to accomplish in my private bundle file is to have the
12176 packages that need to be configured early in the file and the gentle
12177 ones later, so I can go out after a few minutes and leave CPAN.pm
12178 untended.
12179
12180 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
12181
12182 Thanks to Graham Barr for contributing the following paragraphs about
12183 the interaction between perl, and various firewall configurations. For
12184 further information on firewalls, it is recommended to consult the
12185 documentation that comes with the ncftp program. If you are unable to
12186 go through the firewall with a simple Perl setup, it is very likely
12187 that you can configure ncftp so that it works for your firewall.
12188
12189 =head2 Three basic types of firewalls
12190
12191 Firewalls can be categorized into three basic types.
12192
12193 =over 4
12194
12195 =item http firewall
12196
12197 This is where the firewall machine runs a web server and to access the
12198 outside world you must do it via the web server. If you set environment
12199 variables like http_proxy or ftp_proxy to a values beginning with http://
12200 or in your web browser you have to set proxy information then you know
12201 you are running an http firewall.
12202
12203 To access servers outside these types of firewalls with perl (even for
12204 ftp) you will need to use LWP.
12205
12206 =item ftp firewall
12207
12208 This where the firewall machine runs an ftp server. This kind of
12209 firewall will only let you access ftp servers outside the firewall.
12210 This is usually done by connecting to the firewall with ftp, then
12211 entering a username like "user@outside.host.com"
12212
12213 To access servers outside these type of firewalls with perl you
12214 will need to use Net::FTP.
12215
12216 =item One way visibility
12217
12218 I say one way visibility as these firewalls try to make themselves look
12219 invisible to the users inside the firewall. An FTP data connection is
12220 normally created by sending the remote server your IP address and then
12221 listening for the connection. But the remote server will not be able to
12222 connect to you because of the firewall. So for these types of firewall
12223 FTP connections need to be done in a passive mode.
12224
12225 There are two that I can think off.
12226
12227 =over 4
12228
12229 =item SOCKS
12230
12231 If you are using a SOCKS firewall you will need to compile perl and link
12232 it with the SOCKS library, this is what is normally called a 'socksified'
12233 perl. With this executable you will be able to connect to servers outside
12234 the firewall as if it is not there.
12235
12236 =item IP Masquerade
12237
12238 This is the firewall implemented in the Linux kernel, it allows you to
12239 hide a complete network behind one IP address. With this firewall no
12240 special compiling is needed as you can access hosts directly.
12241
12242 For accessing ftp servers behind such firewalls you usually need to
12243 set the environment variable C<FTP_PASSIVE> or the config variable
12244 ftp_passive to a true value.
12245
12246 =back
12247
12248 =back
12249
12250 =head2 Configuring lynx or ncftp for going through a firewall
12251
12252 If you can go through your firewall with e.g. lynx, presumably with a
12253 command such as
12254
12255     /usr/local/bin/lynx -pscott:tiger
12256
12257 then you would configure CPAN.pm with the command
12258
12259     o conf lynx "/usr/local/bin/lynx -pscott:tiger"
12260
12261 That's all. Similarly for ncftp or ftp, you would configure something
12262 like
12263
12264     o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
12265
12266 Your mileage may vary...
12267
12268 =head1 FAQ
12269
12270 =over 4
12271
12272 =item 1)
12273
12274 I installed a new version of module X but CPAN keeps saying,
12275 I have the old version installed
12276
12277 Most probably you B<do> have the old version installed. This can
12278 happen if a module installs itself into a different directory in the
12279 @INC path than it was previously installed. This is not really a
12280 CPAN.pm problem, you would have the same problem when installing the
12281 module manually. The easiest way to prevent this behaviour is to add
12282 the argument C<UNINST=1> to the C<make install> call, and that is why
12283 many people add this argument permanently by configuring
12284
12285   o conf make_install_arg UNINST=1
12286
12287 =item 2)
12288
12289 So why is UNINST=1 not the default?
12290
12291 Because there are people who have their precise expectations about who
12292 may install where in the @INC path and who uses which @INC array. In
12293 fine tuned environments C<UNINST=1> can cause damage.
12294
12295 =item 3)
12296
12297 I want to clean up my mess, and install a new perl along with
12298 all modules I have. How do I go about it?
12299
12300 Run the autobundle command for your old perl and optionally rename the
12301 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
12302 with the Configure option prefix, e.g.
12303
12304     ./Configure -Dprefix=/usr/local/perl-5.6.78.9
12305
12306 Install the bundle file you produced in the first step with something like
12307
12308     cpan> install Bundle::mybundle
12309
12310 and you're done.
12311
12312 =item 4)
12313
12314 When I install bundles or multiple modules with one command
12315 there is too much output to keep track of.
12316
12317 You may want to configure something like
12318
12319   o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
12320   o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
12321
12322 so that STDOUT is captured in a file for later inspection.
12323
12324
12325 =item 5)
12326
12327 I am not root, how can I install a module in a personal directory?
12328
12329 First of all, you will want to use your own configuration, not the one
12330 that your root user installed. If you do not have permission to write
12331 in the cpan directory that root has configured, you will be asked if
12332 you want to create your own config. Answering "yes" will bring you into
12333 CPAN's configuration stage, using the system config for all defaults except
12334 things that have to do with CPAN's work directory, saving your choices to
12335 your MyConfig.pm file.
12336
12337 You can also manually initiate this process with the following command:
12338
12339     % perl -MCPAN -e 'mkmyconfig'
12340
12341 or by running
12342
12343     mkmyconfig
12344
12345 from the CPAN shell.
12346
12347 You will most probably also want to configure something like this:
12348
12349   o conf makepl_arg "LIB=~/myperl/lib \
12350                     INSTALLMAN1DIR=~/myperl/man/man1 \
12351                     INSTALLMAN3DIR=~/myperl/man/man3 \
12352                     INSTALLSCRIPT=~/myperl/bin \
12353                     INSTALLBIN=~/myperl/bin"
12354
12355 and then (oh joy) the equivalent command for Module::Build. That would
12356 be
12357
12358   o conf mbuildpl_arg "--lib=~/myperl/lib \
12359                     --installman1dir=~/myperl/man/man1 \
12360                     --installman3dir=~/myperl/man/man3 \
12361                     --installscript=~/myperl/bin \
12362                     --installbin=~/myperl/bin"
12363
12364 You can make this setting permanent like all C<o conf> settings with
12365 C<o conf commit> or by setting C<auto_commit> beforehand.
12366
12367 You will have to add ~/myperl/man to the MANPATH environment variable
12368 and also tell your perl programs to look into ~/myperl/lib, e.g. by
12369 including
12370
12371   use lib "$ENV{HOME}/myperl/lib";
12372
12373 or setting the PERL5LIB environment variable.
12374
12375 While we're speaking about $ENV{HOME}, it might be worth mentioning,
12376 that for Windows we use the File::HomeDir module that provides an
12377 equivalent to the concept of the home directory on Unix.
12378
12379 Another thing you should bear in mind is that the UNINST parameter can
12380 be dangerous when you are installing into a private area because you
12381 might accidentally remove modules that other people depend on that are
12382 not using the private area.
12383
12384 =item 6)
12385
12386 How to get a package, unwrap it, and make a change before building it?
12387
12388 Have a look at the C<look> (!) command.
12389
12390 =item 7)
12391
12392 I installed a Bundle and had a couple of fails. When I
12393 retried, everything resolved nicely. Can this be fixed to work
12394 on first try?
12395
12396 The reason for this is that CPAN does not know the dependencies of all
12397 modules when it starts out. To decide about the additional items to
12398 install, it just uses data found in the META.yml file or the generated
12399 Makefile. An undetected missing piece breaks the process. But it may
12400 well be that your Bundle installs some prerequisite later than some
12401 depending item and thus your second try is able to resolve everything.
12402 Please note, CPAN.pm does not know the dependency tree in advance and
12403 cannot sort the queue of things to install in a topologically correct
12404 order. It resolves perfectly well IF all modules declare the
12405 prerequisites correctly with the PREREQ_PM attribute to MakeMaker or
12406 the C<requires> stanza of Module::Build. For bundles which fail and
12407 you need to install often, it is recommended to sort the Bundle
12408 definition file manually.
12409
12410 =item 8)
12411
12412 In our intranet we have many modules for internal use. How
12413 can I integrate these modules with CPAN.pm but without uploading
12414 the modules to CPAN?
12415
12416 Have a look at the CPAN::Site module.
12417
12418 =item 9)
12419
12420 When I run CPAN's shell, I get an error message about things in my
12421 /etc/inputrc (or ~/.inputrc) file.
12422
12423 These are readline issues and can only be fixed by studying readline
12424 configuration on your architecture and adjusting the referenced file
12425 accordingly. Please make a backup of the /etc/inputrc or ~/.inputrc
12426 and edit them. Quite often harmless changes like uppercasing or
12427 lowercasing some arguments solves the problem.
12428
12429 =item 10)
12430
12431 Some authors have strange characters in their names.
12432
12433 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
12434 expecting ISO-8859-1 charset, a converter can be activated by setting
12435 term_is_latin to a true value in your config file. One way of doing so
12436 would be
12437
12438     cpan> o conf term_is_latin 1
12439
12440 If other charset support is needed, please file a bugreport against
12441 CPAN.pm at rt.cpan.org and describe your needs. Maybe we can extend
12442 the support or maybe UTF-8 terminals become widely available.
12443
12444 Note: this config variable is deprecated and will be removed in a
12445 future version of CPAN.pm. It will be replaced with the conventions
12446 around the family of $LANG and $LC_* environment variables.
12447
12448 =item 11)
12449
12450 When an install fails for some reason and then I correct the error
12451 condition and retry, CPAN.pm refuses to install the module, saying
12452 C<Already tried without success>.
12453
12454 Use the force pragma like so
12455
12456   force install Foo::Bar
12457
12458 Or you can use
12459
12460   look Foo::Bar
12461
12462 and then 'make install' directly in the subshell.
12463
12464 =item 12)
12465
12466 How do I install a "DEVELOPER RELEASE" of a module?
12467
12468 By default, CPAN will install the latest non-developer release of a
12469 module. If you want to install a dev release, you have to specify the
12470 partial path starting with the author id to the tarball you wish to
12471 install, like so:
12472
12473     cpan> install KWILLIAMS/Module-Build-0.27_07.tar.gz
12474
12475 Note that you can use the C<ls> command to get this path listed.
12476
12477 =item 13)
12478
12479 How do I install a module and all its dependencies from the commandline,
12480 without being prompted for anything, despite my CPAN configuration
12481 (or lack thereof)?
12482
12483 CPAN uses ExtUtils::MakeMaker's prompt() function to ask its questions, so
12484 if you set the PERL_MM_USE_DEFAULT environment variable, you shouldn't be
12485 asked any questions at all (assuming the modules you are installing are
12486 nice about obeying that variable as well):
12487
12488     % PERL_MM_USE_DEFAULT=1 perl -MCPAN -e 'install My::Module'
12489
12490 =item 14)
12491
12492 How do I create a Module::Build based Build.PL derived from an
12493 ExtUtils::MakeMaker focused Makefile.PL?
12494
12495 http://search.cpan.org/search?query=Module::Build::Convert
12496
12497 http://www.refcnt.org/papers/module-build-convert
12498
12499 =item 15)
12500
12501 What's the best CPAN site for me?
12502
12503 The urllist config parameter is yours. You can add and remove sites at
12504 will. You should find out which sites have the best uptodateness,
12505 bandwidth, reliability, etc. and are topologically close to you. Some
12506 people prefer fast downloads, others uptodateness, others reliability.
12507 You decide which to try in which order.
12508
12509 Henk P. Penning maintains a site that collects data about CPAN sites:
12510
12511   http://www.cs.uu.nl/people/henkp/mirmon/cpan.html
12512
12513 =item 16)
12514
12515 Why do I get asked the same questions every time I start the shell?
12516
12517 You can make your configuration changes permanent by calling the
12518 command C<o conf commit>. Alternatively set the C<auto_commit>
12519 variable to true by running C<o conf init auto_commit> and answering
12520 the following question with yes.
12521
12522 =back
12523
12524 =head1 COMPATIBILITY
12525
12526 =head2 OLD PERL VERSIONS
12527
12528 CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted
12529 newer versions. It is getting more and more difficult to get the
12530 minimal prerequisites working on older perls. It is close to
12531 impossible to get the whole Bundle::CPAN working there. If you're in
12532 the position to have only these old versions, be advised that CPAN is
12533 designed to work fine without the Bundle::CPAN installed.
12534
12535 To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is
12536 compatible with ancient perls and that File::Temp is listed as a
12537 prerequisite but CPAN has reasonable workarounds if it is missing.
12538
12539 =head2 CPANPLUS
12540
12541 This module and its competitor, the CPANPLUS module, are both much
12542 cooler than the other. CPAN.pm is older. CPANPLUS was designed to be
12543 more modular but it was never tried to make it compatible with CPAN.pm.
12544
12545 =head1 SECURITY ADVICE
12546
12547 This software enables you to upgrade software on your computer and so
12548 is inherently dangerous because the newly installed software may
12549 contain bugs and may alter the way your computer works or even make it
12550 unusable. Please consider backing up your data before every upgrade.
12551
12552 =head1 BUGS
12553
12554 Please report bugs via L<http://rt.cpan.org/>
12555
12556 Before submitting a bug, please make sure that the traditional method
12557 of building a Perl module package from a shell by following the
12558 installation instructions of that package still works in your
12559 environment.
12560
12561 =head1 AUTHOR
12562
12563 Andreas Koenig C<< <andk@cpan.org> >>
12564
12565 =head1 LICENSE
12566
12567 This program is free software; you can redistribute it and/or
12568 modify it under the same terms as Perl itself.
12569
12570 See L<http://www.perl.com/perl/misc/Artistic.html>
12571
12572 =head1 TRANSLATIONS
12573
12574 Kawai,Takanori provides a Japanese translation of this manpage at
12575 L<http://homepage3.nifty.com/hippo2000/perltips/CPAN.htm>
12576
12577 =head1 SEE ALSO
12578
12579 L<cpan>, L<CPAN::Nox>, L<CPAN::Version>
12580
12581 =cut
12582
12583