lib/CPAN.pm

   1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
   2 use strict;
   3 package CPAN;
   4 $CPAN::VERSION = '1.9203';
   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 # we need to run chdir all over and we would get at wrong libraries
  34 # there
  35 BEGIN {
  36     if (File::Spec->can("rel2abs")) {
  37         for my $inc (@INC) {
  38             $inc = File::Spec->rel2abs($inc) unless ref $inc;
  39         }
  40     }
  41 }
  42 no lib ".";
  43
  44 require Mac::BuildTools if $^O eq 'MacOS';
  45 $ENV{PERL5_CPAN_IS_RUNNING}=$$;
  46 $ENV{PERL5_CPANPLUS_IS_RUNNING}=$$; # https://rt.cpan.org/Ticket/Display.html?id=23735
  47
  48 END { $CPAN::End++; &cleanup; }
  49
  50 $CPAN::Signal ||= 0;
  51 $CPAN::Frontend ||= "CPAN::Shell";
  52 unless (@CPAN::Defaultsites) {
  53     @CPAN::Defaultsites = map {
  54         CPAN::URL->new(TEXT => $_, FROM => "DEF")
  55     }
  56         "http://www.perl.org/CPAN/",
  57             "ftp://ftp.perl.org/pub/CPAN/";
  58 }
  59 # $CPAN::iCwd (i for initial) is going to be initialized during find_perl
  60 $CPAN::Perl ||= CPAN::find_perl();
  61 $CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?";
  62 $CPAN::Defaultrecent ||= "http://search.cpan.org/uploads.rdf";
  63 $CPAN::Defaultrecent ||= "http://cpan.uwinnipeg.ca/htdocs/cpan.xml";
  64
  65 # our globals are getting a mess
  66 use vars qw(
  67             $AUTOLOAD
  68             $Be_Silent
  69             $CONFIG_DIRTY
  70             $Defaultdocs
  71             $Echo_readline
  72             $Frontend
  73             $GOTOSHELL
  74             $HAS_USABLE
  75             $Have_warned
  76             $MAX_RECURSION
  77             $META
  78             $RUN_DEGRADED
  79             $Signal
  80             $SQLite
  81             $Suppress_readline
  82             $VERSION
  83             $autoload_recursion
  84             $term
  85             @Defaultsites
  86             @EXPORT
  87            );
  88
  89 $MAX_RECURSION = 32;
  90
  91 @CPAN::ISA = qw(CPAN::Debug Exporter);
  92
  93 # note that these functions live in CPAN::Shell and get executed via
  94 # AUTOLOAD when called directly
  95 @EXPORT = qw(
  96              autobundle
  97              bundle
  98              clean
  99              cvs_import
 100              expand
 101              force
 102              fforce
 103              get
 104              install
 105              install_tested
 106              is_tested
 107              make
 108              mkmyconfig
 109              notest
 110              perldoc
 111              readme
 112              recent
 113              recompile
 114              report
 115              shell
 116              smoke
 117              test
 118              upgrade
 119             );
 120
 121 sub soft_chdir_with_alternatives ($);
 122
 123 {
 124     $autoload_recursion ||= 0;
 125
 126     #-> sub CPAN::AUTOLOAD ;
 127     sub AUTOLOAD {
 128         $autoload_recursion++;
 129         my($l) = $AUTOLOAD;
 130         $l =~ s/.*:://;
 131         if ($CPAN::Signal) {
 132             warn "Refusing to autoload '$l' while signal pending";
 133             $autoload_recursion--;
 134             return;
 135         }
 136         if ($autoload_recursion > 1) {
 137             my $fullcommand = join " ", map { "'$_'" } $l, @_;
 138             warn "Refusing to autoload $fullcommand in recursion\n";
 139             $autoload_recursion--;
 140             return;
 141         }
 142         my(%export);
 143         @export{@EXPORT} = '';
 144         CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 145         if (exists $export{$l}) {
 146             CPAN::Shell->$l(@_);
 147         } else {
 148             die(qq{Unknown CPAN command "$AUTOLOAD". }.
 149                 qq{Type ? for help.\n});
 150         }
 151         $autoload_recursion--;
 152     }
 153 }
 154
 155 #-> sub CPAN::shell ;
 156 sub shell {
 157     my($self) = @_;
 158     $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
 159     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 160
 161     my $oprompt = shift || CPAN::Prompt->new;
 162     my $prompt = $oprompt;
 163     my $commandline = shift || "";
 164     $CPAN::CurrentCommandId ||= 1;
 165
 166     local($^W) = 1;
 167     unless ($Suppress_readline) {
 168         require Term::ReadLine;
 169         if (! $term
 170             or
 171             $term->ReadLine eq "Term::ReadLine::Stub"
 172            ) {
 173             $term = Term::ReadLine->new('CPAN Monitor');
 174         }
 175         if ($term->ReadLine eq "Term::ReadLine::Gnu") {
 176             my $attribs = $term->Attribs;
 177             $attribs->{attempted_completion_function} = sub {
 178                 &CPAN::Complete::gnu_cpl;
 179             }
 180         } else {
 181             $readline::rl_completion_function =
 182                 $readline::rl_completion_function = 'CPAN::Complete::cpl';
 183         }
 184         if (my $histfile = $CPAN::Config->{'histfile'}) {{
 185             unless ($term->can("AddHistory")) {
 186                 $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
 187                 last;
 188             }
 189             $META->readhist($term,$histfile);
 190         }}
 191         for ($CPAN::Config->{term_ornaments}) { # alias
 192             local $Term::ReadLine::termcap_nowarn = 1;
 193             $term->ornaments($_) if defined;
 194         }
 195         # $term->OUT is autoflushed anyway
 196         my $odef = select STDERR;
 197         $| = 1;
 198         select STDOUT;
 199         $| = 1;
 200         select $odef;
 201     }
 202
 203     $META->checklock();
 204     my @cwd = grep { defined $_ and length $_ }
 205         CPAN::anycwd(),
 206               File::Spec->can("tmpdir") ? File::Spec->tmpdir() : (),
 207                     File::Spec->rootdir();
 208     my $try_detect_readline;
 209     $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
 210     unless ($CPAN::Config->{inhibit_startup_message}) {
 211         my $rl_avail = $Suppress_readline ? "suppressed" :
 212             ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
 213                 "available (maybe install Bundle::CPAN or Bundle::CPANxxl?)";
 214         $CPAN::Frontend->myprint(
 215                                  sprintf qq{
 216 cpan shell -- CPAN exploration and modules installation (v%s)
 217 ReadLine support %s
 218
 219 },
 220                                  $CPAN::VERSION,
 221                                  $rl_avail
 222                                 )
 223     }
 224     my($continuation) = "";
 225     my $last_term_ornaments;
 226   SHELLCOMMAND: while () {
 227         if ($Suppress_readline) {
 228             if ($Echo_readline) {
 229                 $|=1;
 230             }
 231             print $prompt;
 232             last SHELLCOMMAND unless defined ($_ = <> );
 233             if ($Echo_readline) {
 234                 # backdoor: I could not find a way to record sessions
 235                 print $_;
 236             }
 237             chomp;
 238         } else {
 239             last SHELLCOMMAND unless
 240                 defined ($_ = $term->readline($prompt, $commandline));
 241         }
 242         $_ = "$continuation$_" if $continuation;
 243         s/^\s+//;
 244         next SHELLCOMMAND if /^$/;
 245         s/^\s*\?\s*/help /;
 246         if (/^(?:q(?:uit)?|bye|exit)$/i) {
 247             last SHELLCOMMAND;
 248         } elsif (s/\\$//s) {
 249             chomp;
 250             $continuation = $_;
 251             $prompt = "    > ";
 252         } elsif (/^\!/) {
 253             s/^\!//;
 254             my($eval) = $_;
 255             package CPAN::Eval;
 256             use strict;
 257             use vars qw($import_done);
 258             CPAN->import(':DEFAULT') unless $import_done++;
 259             CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
 260             eval($eval);
 261             warn $@ if $@;
 262             $continuation = "";
 263             $prompt = $oprompt;
 264         } elsif (/./) {
 265             my(@line);
 266             eval { @line = Text::ParseWords::shellwords($_) };
 267             warn($@), next SHELLCOMMAND if $@;
 268             warn("Text::Parsewords could not parse the line [$_]"),
 269                 next SHELLCOMMAND unless @line;
 270             $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
 271             my $command = shift @line;
 272             eval { CPAN::Shell->$command(@line) };
 273             if ($@) {
 274                 my $err = "$@";
 275                 if ($err =~ /\S/) {
 276                     require Carp;
 277                     require Dumpvalue;
 278                     my $dv = Dumpvalue->new();
 279                     Carp::cluck(sprintf "Catching error: %s", $dv->stringify($err));
 280                 }
 281             }
 282             if ($command =~ /^(
 283                              # classic commands
 284                              make
 285                              |test
 286                              |install
 287                              |clean
 288
 289                              # pragmas for classic commands
 290                              |ff?orce
 291                              |notest
 292
 293                              # compounds
 294                              |report
 295                              |smoke
 296                              |upgrade
 297                             )$/x) {
 298                 # only commands that tell us something about failed distros
 299                 CPAN::Shell->failed($CPAN::CurrentCommandId,1);
 300             }
 301             soft_chdir_with_alternatives(\@cwd);
 302             $CPAN::Frontend->myprint("\n");
 303             $continuation = "";
 304             $CPAN::CurrentCommandId++;
 305             $prompt = $oprompt;
 306         }
 307     } continue {
 308         $commandline = ""; # I do want to be able to pass a default to
 309                            # shell, but on the second command I see no
 310                            # use in that
 311         $Signal=0;
 312         CPAN::Queue->nullify_queue;
 313         if ($try_detect_readline) {
 314             if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
 315                 ||
 316                 $CPAN::META->has_inst("Term::ReadLine::Perl")
 317             ) {
 318                 delete $INC{"Term/ReadLine.pm"};
 319                 my $redef = 0;
 320                 local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
 321                 require Term::ReadLine;
 322                 $CPAN::Frontend->myprint("\n$redef subroutines in ".
 323                                          "Term::ReadLine redefined\n");
 324                 $GOTOSHELL = 1;
 325             }
 326         }
 327         if ($term and $term->can("ornaments")) {
 328             for ($CPAN::Config->{term_ornaments}) { # alias
 329                 if (defined $_) {
 330                     if (not defined $last_term_ornaments
 331                         or $_ != $last_term_ornaments
 332                     ) {
 333                         local $Term::ReadLine::termcap_nowarn = 1;
 334                         $term->ornaments($_);
 335                         $last_term_ornaments = $_;
 336                     }
 337                 } else {
 338                     undef $last_term_ornaments;
 339                 }
 340             }
 341         }
 342         for my $class (qw(Module Distribution)) {
 343             # again unsafe meta access?
 344             for my $dm (keys %{$CPAN::META->{readwrite}{"CPAN::$class"}}) {
 345                 next unless $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
 346                 CPAN->debug("BUG: $class '$dm' was in command state, resetting");
 347                 delete $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
 348             }
 349         }
 350         if ($GOTOSHELL) {
 351             $GOTOSHELL = 0; # not too often
 352             $META->savehist if $CPAN::term && $CPAN::term->can("GetHistory");
 353             @_ = ($oprompt,"");
 354             goto &shell;
 355         }
 356     }
 357     soft_chdir_with_alternatives(\@cwd);
 358 }
 359
 360 sub soft_chdir_with_alternatives ($) {
 361     my($cwd) = @_;
 362     unless (@$cwd) {
 363         my $root = File::Spec->rootdir();
 364         $CPAN::Frontend->mywarn(qq{Warning: no good directory to chdir to!
 365 Trying '$root' as temporary haven.
 366 });
 367         push @$cwd, $root;
 368     }
 369     while () {
 370         if (chdir $cwd->[0]) {
 371             return;
 372         } else {
 373             if (@$cwd>1) {
 374                 $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $!
 375 Trying to chdir to "$cwd->[1]" instead.
 376 });
 377                 shift @$cwd;
 378             } else {
 379                 $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!});
 380             }
 381         }
 382     }
 383 }
 384
 385 sub _flock {
 386     my($fh,$mode) = @_;
 387     if ($Config::Config{d_flock}) {
 388         return flock $fh, $mode;
 389     } elsif (!$Have_warned->{"d_flock"}++) {
 390         $CPAN::Frontend->mywarn("Your OS does not support locking; continuing and ignoring all locking issues\n");
 391         $CPAN::Frontend->mysleep(5);
 392         return 1;
 393     } else {
 394         return 1;
 395     }
 396 }
 397
 398 sub _yaml_module () {
 399     my $yaml_module = $CPAN::Config->{yaml_module} || "YAML";
 400     if (
 401         $yaml_module ne "YAML"
 402         &&
 403         !$CPAN::META->has_inst($yaml_module)
 404        ) {
 405         # $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back to 'YAML'\n");
 406         $yaml_module = "YAML";
 407     }
 408     if ($yaml_module eq "YAML"
 409         &&
 410         $CPAN::META->has_inst($yaml_module)
 411         &&
 412         $YAML::VERSION < 0.60
 413         &&
 414         !$Have_warned->{"YAML"}++
 415        ) {
 416         $CPAN::Frontend->mywarn("Warning: YAML version '$YAML::VERSION' is too low, please upgrade!\n".
 417                                 "I'll continue but problems are *very* likely to happen.\n"
 418                                );
 419         $CPAN::Frontend->mysleep(5);
 420     }
 421     return $yaml_module;
 422 }
 423
 424 # CPAN::_yaml_loadfile
 425 sub _yaml_loadfile {
 426     my($self,$local_file) = @_;
 427     return +[] unless -s $local_file;
 428     my $yaml_module = _yaml_module;
 429     if ($CPAN::META->has_inst($yaml_module)) {
 430         # temporarly enable yaml code deserialisation
 431         no strict 'refs';
 432         # 5.6.2 could not do the local() with the reference
 433         local $YAML::LoadCode;
 434         local $YAML::Syck::LoadCode;
 435         ${ "$yaml_module\::LoadCode" } = $CPAN::Config->{yaml_load_code} || 0;
 436
 437         my $code;
 438         if ($code = UNIVERSAL::can($yaml_module, "LoadFile")) {
 439             my @yaml;
 440             eval { @yaml = $code->($local_file); };
 441             if ($@) {
 442                 # this shall not be done by the frontend
 443                 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
 444             }
 445             return \@yaml;
 446         } elsif ($code = UNIVERSAL::can($yaml_module, "Load")) {
 447             local *FH;
 448             open FH, $local_file or die "Could not open '$local_file': $!";
 449             local $/;
 450             my $ystream = <FH>;
 451             my @yaml;
 452             eval { @yaml = $code->($ystream); };
 453             if ($@) {
 454                 # this shall not be done by the frontend
 455                 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
 456             }
 457             return \@yaml;
 458         }
 459     } else {
 460         # this shall not be done by the frontend
 461         die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "parse");
 462     }
 463     return +[];
 464 }
 465
 466 # CPAN::_yaml_dumpfile
 467 sub _yaml_dumpfile {
 468     my($self,$local_file,@what) = @_;
 469     my $yaml_module = _yaml_module;
 470     if ($CPAN::META->has_inst($yaml_module)) {
 471         my $code;
 472         if (UNIVERSAL::isa($local_file, "FileHandle")) {
 473             $code = UNIVERSAL::can($yaml_module, "Dump");
 474             eval { print $local_file $code->(@what) };
 475         } elsif ($code = UNIVERSAL::can($yaml_module, "DumpFile")) {
 476             eval { $code->($local_file,@what); };
 477         } elsif ($code = UNIVERSAL::can($yaml_module, "Dump")) {
 478             local *FH;
 479             open FH, ">$local_file" or die "Could not open '$local_file': $!";
 480             print FH $code->(@what);
 481         }
 482         if ($@) {
 483             die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"dump",$@);
 484         }
 485     } else {
 486         if (UNIVERSAL::isa($local_file, "FileHandle")) {
 487             # I think this case does not justify a warning at all
 488         } else {
 489             die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "dump");
 490         }
 491     }
 492 }
 493
 494 sub _init_sqlite () {
 495     unless ($CPAN::META->has_inst("CPAN::SQLite")) {
 496         $CPAN::Frontend->mywarn(qq{CPAN::SQLite not installed, trying to work without\n})
 497             unless $Have_warned->{"CPAN::SQLite"}++;
 498         return;
 499     }
 500     require CPAN::SQLite::META; # not needed since CVS version of 2006-12-17
 501     $CPAN::SQLite ||= CPAN::SQLite::META->new($CPAN::META);
 502 }
 503
 504 {
 505     my $negative_cache = {};
 506     sub _sqlite_running {
 507         if ($negative_cache->{time} && time < $negative_cache->{time} + 60) {
 508             # need to cache the result, otherwise too slow
 509             return $negative_cache->{fact};
 510         } else {
 511             $negative_cache = {}; # reset
 512         }
 513         my $ret = $CPAN::Config->{use_sqlite} && ($CPAN::SQLite || _init_sqlite());
 514         return $ret if $ret; # fast anyway
 515         $negative_cache->{time} = time;
 516         return $negative_cache->{fact} = $ret;
 517     }
 518 }
 519
 520 package CPAN::CacheMgr;
 521 use strict;
 522 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
 523 use File::Find;
 524
 525 package CPAN::FTP;
 526 use strict;
 527 use Fcntl qw(:flock);
 528 use vars qw($connect_to_internet_ok $Ua $Thesite $ThesiteURL $Themethod);
 529 @CPAN::FTP::ISA = qw(CPAN::Debug);
 530
 531 package CPAN::LWP::UserAgent;
 532 use strict;
 533 use vars qw(@ISA $USER $PASSWD $SETUPDONE);
 534 # we delay requiring LWP::UserAgent and setting up inheritance until we need it
 535
 536 package CPAN::Complete;
 537 use strict;
 538 @CPAN::Complete::ISA = qw(CPAN::Debug);
 539 # Q: where is the "How do I add a new command" HOWTO?
 540 # A: svn diff -r 1048:1049 where andk added the report command
 541 @CPAN::Complete::COMMANDS = sort qw(
 542                                     ? ! a b d h i m o q r u
 543                                     autobundle
 544                                     bye
 545                                     clean
 546                                     cvs_import
 547                                     dump
 548                                     exit
 549                                     failed
 550                                     force
 551                                     fforce
 552                                     hosts
 553                                     install
 554                                     install_tested
 555                                     is_tested
 556                                     look
 557                                     ls
 558                                     make
 559                                     mkmyconfig
 560                                     notest
 561                                     perldoc
 562                                     quit
 563                                     readme
 564                                     recent
 565                                     recompile
 566                                     reload
 567                                     report
 568                                     reports
 569                                     scripts
 570                                     smoke
 571                                     test
 572                                     upgrade
 573 );
 574
 575 package CPAN::Index;
 576 use strict;
 577 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED);
 578 @CPAN::Index::ISA = qw(CPAN::Debug);
 579 $LAST_TIME ||= 0;
 580 $DATE_OF_03 ||= 0;
 581 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
 582 sub PROTOCOL { 2.0 }
 583
 584 package CPAN::InfoObj;
 585 use strict;
 586 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
 587
 588 package CPAN::Author;
 589 use strict;
 590 @CPAN::Author::ISA = qw(CPAN::InfoObj);
 591
 592 package CPAN::Distribution;
 593 use strict;
 594 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
 595
 596 package CPAN::Bundle;
 597 use strict;
 598 @CPAN::Bundle::ISA = qw(CPAN::Module);
 599
 600 package CPAN::Module;
 601 use strict;
 602 @CPAN::Module::ISA = qw(CPAN::InfoObj);
 603
 604 package CPAN::Exception::RecursiveDependency;
 605 use strict;
 606 use overload '""' => "as_string";
 607
 608 # a module sees its distribution (no version)
 609 # a distribution sees its prereqs (which are module names) (usually with versions)
 610 # a bundle sees its module names and/or its distributions (no version)
 611
 612 sub new {
 613     my($class) = shift;
 614     my($deps) = shift;
 615     my (@deps,%seen,$loop_starts_with);
 616   DCHAIN: for my $dep (@$deps) {
 617         push @deps, {name => $dep, display_as => $dep};
 618         if ($seen{$dep}++) {
 619             $loop_starts_with = $dep;
 620             last DCHAIN;
 621         }
 622     }
 623     my $in_loop = 0;
 624     for my $i (0..$#deps) {
 625         my $x = $deps[$i]{name};
 626         $in_loop ||= $x eq $loop_starts_with;
 627         my $xo = CPAN::Shell->expandany($x) or next;
 628         if ($xo->isa("CPAN::Module")) {
 629             my $have = $xo->inst_version || "N/A";
 630             my($want,$d,$want_type);
 631             if ($i>0 and $d = $deps[$i-1]{name}) {
 632                 my $do = CPAN::Shell->expandany($d);
 633                 $want = $do->{prereq_pm}{requires}{$x};
 634                 if (defined $want) {
 635                     $want_type = "requires: ";
 636                 } else {
 637                     $want = $do->{prereq_pm}{build_requires}{$x};
 638                     if (defined $want) {
 639                         $want_type = "build_requires: ";
 640                     } else {
 641                         $want_type = "unknown status";
 642                         $want = "???";
 643                     }
 644                 }
 645             } else {
 646                 $want = $xo->cpan_version;
 647                 $want_type = "want: ";
 648             }
 649             $deps[$i]{have} = $have;
 650             $deps[$i]{want_type} = $want_type;
 651             $deps[$i]{want} = $want;
 652             $deps[$i]{display_as} = "$x (have: $have; $want_type$want)";
 653         } elsif ($xo->isa("CPAN::Distribution")) {
 654             $deps[$i]{display_as} = $xo->pretty_id;
 655             if ($in_loop) {
 656                 $xo->{make} = CPAN::Distrostatus->new("NO cannot resolve circular dependency");
 657             } else {
 658                 $xo->{make} = CPAN::Distrostatus->new("NO one dependency ($loop_starts_with) is a circular dependency");
 659             }
 660             $xo->store_persistent_state; # otherwise I will not reach
 661                                          # all involved parties for
 662                                          # the next session
 663         }
 664     }
 665     bless { deps => \@deps }, $class;
 666 }
 667
 668 sub as_string {
 669     my($self) = shift;
 670     my $ret = "\nRecursive dependency detected:\n    ";
 671     $ret .= join("\n => ", map {$_->{display_as}} @{$self->{deps}});
 672     $ret .= ".\nCannot resolve.\n";
 673     $ret;
 674 }
 675
 676 package CPAN::Exception::yaml_not_installed;
 677 use strict;
 678 use overload '""' => "as_string";
 679
 680 sub new {
 681     my($class,$module,$file,$during) = @_;
 682     bless { module => $module, file => $file, during => $during }, $class;
 683 }
 684
 685 sub as_string {
 686     my($self) = shift;
 687     "'$self->{module}' not installed, cannot $self->{during} '$self->{file}'\n";
 688 }
 689
 690 package CPAN::Exception::yaml_process_error;
 691 use strict;
 692 use overload '""' => "as_string";
 693
 694 sub new {
 695     my($class,$module,$file,$during,$error) = @_;
 696     bless { module => $module,
 697             file => $file,
 698             during => $during,
 699             error => $error }, $class;
 700 }
 701
 702 sub as_string {
 703     my($self) = shift;
 704     if ($self->{during}) {
 705         if ($self->{file}) {
 706             if ($self->{module}) {
 707                 if ($self->{error}) {
 708                     return "Alert: While trying to '$self->{during}' YAML file\n".
 709                         " '$self->{file}'\n".
 710                             "with '$self->{module}' the following error was encountered:\n".
 711                                 "  $self->{error}\n";
 712                 } else {
 713                     return "Alert: While trying to '$self->{during}' YAML file\n".
 714                         " '$self->{file}'\n".
 715                             "with '$self->{module}' some unknown error was encountered\n";
 716                 }
 717             } else {
 718                 return "Alert: While trying to '$self->{during}' YAML file\n".
 719                     " '$self->{file}'\n".
 720                         "some unknown error was encountered\n";
 721             }
 722         } else {
 723             return "Alert: While trying to '$self->{during}' some YAML file\n".
 724                     "some unknown error was encountered\n";
 725         }
 726     } else {
 727         return "Alert: unknown error encountered\n";
 728     }
 729 }
 730
 731 package CPAN::Prompt; use overload '""' => "as_string";
 732 use vars qw($prompt);
 733 $prompt = "cpan> ";
 734 $CPAN::CurrentCommandId ||= 0;
 735 sub new {
 736     bless {}, shift;
 737 }
 738 sub as_string {
 739     my $word = "cpan";
 740     unless ($CPAN::META->{LOCK}) {
 741         $word = "nolock_cpan";
 742     }
 743     if ($CPAN::Config->{commandnumber_in_prompt}) {
 744         sprintf "$word\[%d]> ", $CPAN::CurrentCommandId;
 745     } else {
 746         "$word> ";
 747     }
 748 }
 749
 750 package CPAN::URL; use overload '""' => "as_string", fallback => 1;
 751 # accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist),
 752 # planned are things like age or quality
 753 sub new {
 754     my($class,%args) = @_;
 755     bless {
 756            %args
 757           }, $class;
 758 }
 759 sub as_string {
 760     my($self) = @_;
 761     $self->text;
 762 }
 763 sub text {
 764     my($self,$set) = @_;
 765     if (defined $set) {
 766         $self->{TEXT} = $set;
 767     }
 768     $self->{TEXT};
 769 }
 770
 771 package CPAN::Distrostatus;
 772 use overload '""' => "as_string",
 773     fallback => 1;
 774 sub new {
 775     my($class,$arg) = @_;
 776     bless {
 777            TEXT => $arg,
 778            FAILED => substr($arg,0,2) eq "NO",
 779            COMMANDID => $CPAN::CurrentCommandId,
 780            TIME => time,
 781           }, $class;
 782 }
 783 sub commandid { shift->{COMMANDID} }
 784 sub failed { shift->{FAILED} }
 785 sub text {
 786     my($self,$set) = @_;
 787     if (defined $set) {
 788         $self->{TEXT} = $set;
 789     }
 790     $self->{TEXT};
 791 }
 792 sub as_string {
 793     my($self) = @_;
 794     $self->text;
 795 }
 796
 797 package CPAN::Shell;
 798 use strict;
 799 use vars qw(
 800             $ADVANCED_QUERY
 801             $AUTOLOAD
 802             $COLOR_REGISTERED
 803             $Help
 804             $autoload_recursion
 805             $reload
 806             @ISA
 807            );
 808 @CPAN::Shell::ISA = qw(CPAN::Debug);
 809 $COLOR_REGISTERED ||= 0;
 810 $Help = {
 811          '?' => \"help",
 812          '!' => "eval the rest of the line as perl",
 813          a => "whois author",
 814          autobundle => "wtite inventory into a bundle file",
 815          b => "info about bundle",
 816          bye => \"quit",
 817          clean => "clean up a distribution's build directory",
 818          # cvs_import
 819          d => "info about a distribution",
 820          # dump
 821          exit => \"quit",
 822          failed => "list all failed actions within current session",
 823          fforce => "redo a command from scratch",
 824          force => "redo a command",
 825          h => \"help",
 826          help => "overview over commands; 'help ...' explains specific commands",
 827          hosts => "statistics about recently used hosts",
 828          i => "info about authors/bundles/distributions/modules",
 829          install => "install a distribution",
 830          install_tested => "install all distributions tested OK",
 831          is_tested => "list all distributions tested OK",
 832          look => "open a subshell in a distribution's directory",
 833          ls => "list distributions according to a glob",
 834          m => "info about a module",
 835          make => "make/build a distribution",
 836          mkmyconfig => "write current config into a CPAN/MyConfig.pm file",
 837          notest => "run a (usually install) command but leave out the test phase",
 838          o => "'o conf ...' for config stuff; 'o debug ...' for debugging",
 839          perldoc => "try to get a manpage for a module",
 840          q => \"quit",
 841          quit => "leave the cpan shell",
 842          r => "review over upgradeable modules",
 843          readme => "display the README of a distro woth a pager",
 844          recent => "show recent uploads to the CPAN",
 845          # recompile
 846          reload => "'reload cpan' or 'reload index'",
 847          report => "test a distribution and send a test report to cpantesters",
 848          reports => "info about reported tests from cpantesters",
 849          # scripts
 850          # smoke
 851          test => "test a distribution",
 852          u => "display uninstalled modules",
 853          upgrade => "combine 'r' command with immediate installation",
 854         };
 855 {
 856     $autoload_recursion   ||= 0;
 857
 858     #-> sub CPAN::Shell::AUTOLOAD ;
 859     sub AUTOLOAD {
 860         $autoload_recursion++;
 861         my($l) = $AUTOLOAD;
 862         my $class = shift(@_);
 863         # warn "autoload[$l] class[$class]";
 864         $l =~ s/.*:://;
 865         if ($CPAN::Signal) {
 866             warn "Refusing to autoload '$l' while signal pending";
 867             $autoload_recursion--;
 868             return;
 869         }
 870         if ($autoload_recursion > 1) {
 871             my $fullcommand = join " ", map { "'$_'" } $l, @_;
 872             warn "Refusing to autoload $fullcommand in recursion\n";
 873             $autoload_recursion--;
 874             return;
 875         }
 876         if ($l =~ /^w/) {
 877             # XXX needs to be reconsidered
 878             if ($CPAN::META->has_inst('CPAN::WAIT')) {
 879                 CPAN::WAIT->$l(@_);
 880             } else {
 881                 $CPAN::Frontend->mywarn(qq{
 882 Commands starting with "w" require CPAN::WAIT to be installed.
 883 Please consider installing CPAN::WAIT to use the fulltext index.
 884 For this you just need to type
 885     install CPAN::WAIT
 886 });
 887             }
 888         } else {
 889             $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }.
 890                                     qq{Type ? for help.
 891 });
 892         }
 893         $autoload_recursion--;
 894     }
 895 }
 896
 897 package CPAN;
 898 use strict;
 899
 900 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
 901
 902 # from here on only subs.
 903 ################################################################################
 904
 905 sub _perl_fingerprint {
 906     my($self,$other_fingerprint) = @_;
 907     my $dll = eval {OS2::DLLname()};
 908     my $mtime_dll = 0;
 909     if (defined $dll) {
 910         $mtime_dll = (-f $dll ? (stat(_))[9] : '-1');
 911     }
 912     my $mtime_perl = (-f $^X ? (stat(_))[9] : '-1');
 913     my $this_fingerprint = {
 914                             '$^X' => $^X,
 915                             sitearchexp => $Config::Config{sitearchexp},
 916                             'mtime_$^X' => $mtime_perl,
 917                             'mtime_dll' => $mtime_dll,
 918                            };
 919     if ($other_fingerprint) {
 920         if (exists $other_fingerprint->{'stat($^X)'}) { # repair fp from rev. 1.88_57
 921             $other_fingerprint->{'mtime_$^X'} = $other_fingerprint->{'stat($^X)'}[9];
 922         }
 923         # mandatory keys since 1.88_57
 924         for my $key (qw($^X sitearchexp mtime_dll mtime_$^X)) {
 925             return unless $other_fingerprint->{$key} eq $this_fingerprint->{$key};
 926         }
 927         return 1;
 928     } else {
 929         return $this_fingerprint;
 930     }
 931 }
 932
 933 sub suggest_myconfig () {
 934   SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) {
 935         $CPAN::Frontend->myprint("You don't seem to have a user ".
 936                                  "configuration (MyConfig.pm) yet.\n");
 937         my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ".
 938                                               "user configuration now? (Y/n)",
 939                                               "yes");
 940         if($new =~ m{^y}i) {
 941             CPAN::Shell->mkmyconfig();
 942             return &checklock;
 943         } else {
 944             $CPAN::Frontend->mydie("OK, giving up.");
 945         }
 946     }
 947 }
 948
 949 #-> sub CPAN::all_objects ;
 950 sub all_objects {
 951     my($mgr,$class) = @_;
 952     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 953     CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
 954     CPAN::Index->reload;
 955     values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
 956 }
 957
 958 # Called by shell, not in batch mode. In batch mode I see no risk in
 959 # having many processes updating something as installations are
 960 # continually checked at runtime. In shell mode I suspect it is
 961 # unintentional to open more than one shell at a time
 962
 963 #-> sub CPAN::checklock ;
 964 sub checklock {
 965     my($self) = @_;
 966     my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
 967     if (-f $lockfile && -M _ > 0) {
 968         my $fh = FileHandle->new($lockfile) or
 969             $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
 970         my $otherpid  = <$fh>;
 971         my $otherhost = <$fh>;
 972         $fh->close;
 973         if (defined $otherpid && $otherpid) {
 974             chomp $otherpid;
 975         }
 976         if (defined $otherhost && $otherhost) {
 977             chomp $otherhost;
 978         }
 979         my $thishost  = hostname();
 980         if (defined $otherhost && defined $thishost &&
 981             $otherhost ne '' && $thishost ne '' &&
 982             $otherhost ne $thishost) {
 983             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
 984                                            "reports other host $otherhost and other ".
 985                                            "process $otherpid.\n".
 986                                            "Cannot proceed.\n"));
 987         } elsif ($RUN_DEGRADED) {
 988             $CPAN::Frontend->mywarn("Running in degraded mode (experimental)\n");
 989         } elsif (defined $otherpid && $otherpid) {
 990             return if $$ == $otherpid; # should never happen
 991             $CPAN::Frontend->mywarn(
 992                                     qq{
 993 There seems to be running another CPAN process (pid $otherpid).  Contacting...
 994 });
 995             if (kill 0, $otherpid) {
 996                 $CPAN::Frontend->mywarn(qq{Other job is running.\n});
 997                 my($ans) =
 998                     CPAN::Shell::colorable_makemaker_prompt
 999                         (qq{Shall I try to run in degraded }.
1000                         qq{mode? (Y/n)},"y");
1001                 if ($ans =~ /^y/i) {
1002                     $CPAN::Frontend->mywarn("Running in degraded mode (experimental).
1003 Please report if something unexpected happens\n");
1004                     $RUN_DEGRADED = 1;
1005                     for ($CPAN::Config) {
1006                         # XXX
1007                         # $_->{build_dir_reuse} = 0; # 2006-11-17 akoenig Why was that?
1008                         $_->{commandnumber_in_prompt} = 0; # visibility
1009                         $_->{histfile} = "";               # who should win otherwise?
1010                         $_->{cache_metadata} = 0;          # better would be a lock?
1011                         $_->{use_sqlite} = 0;              # better would be a write lock!
1012                     }
1013                 } else {
1014                     $CPAN::Frontend->mydie("
1015 You may want to kill the other job and delete the lockfile. On UNIX try:
1016     kill $otherpid
1017     rm $lockfile
1018 ");
1019                 }
1020             } elsif (-w $lockfile) {
1021                 my($ans) =
1022                     CPAN::Shell::colorable_makemaker_prompt
1023                         (qq{Other job not responding. Shall I overwrite }.
1024                         qq{the lockfile '$lockfile'? (Y/n)},"y");
1025             $CPAN::Frontend->myexit("Ok, bye\n")
1026                 unless $ans =~ /^y/i;
1027             } else {
1028                 Carp::croak(
1029                     qq{Lockfile '$lockfile' not writeable by you. }.
1030                     qq{Cannot proceed.\n}.
1031                     qq{    On UNIX try:\n}.
1032                     qq{    rm '$lockfile'\n}.
1033                     qq{  and then rerun us.\n}
1034                 );
1035             }
1036         } else {
1037             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Found invalid lockfile ".
1038                                            "'$lockfile', please remove. Cannot proceed.\n"));
1039         }
1040     }
1041     my $dotcpan = $CPAN::Config->{cpan_home};
1042     eval { File::Path::mkpath($dotcpan);};
1043     if ($@) {
1044         # A special case at least for Jarkko.
1045         my $firsterror = $@;
1046         my $seconderror;
1047         my $symlinkcpan;
1048         if (-l $dotcpan) {
1049             $symlinkcpan = readlink $dotcpan;
1050             die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
1051             eval { File::Path::mkpath($symlinkcpan); };
1052             if ($@) {
1053                 $seconderror = $@;
1054             } else {
1055                 $CPAN::Frontend->mywarn(qq{
1056 Working directory $symlinkcpan created.
1057 });
1058             }
1059         }
1060         unless (-d $dotcpan) {
1061             my $mess = qq{
1062 Your configuration suggests "$dotcpan" as your
1063 CPAN.pm working directory. I could not create this directory due
1064 to this error: $firsterror\n};
1065             $mess .= qq{
1066 As "$dotcpan" is a symlink to "$symlinkcpan",
1067 I tried to create that, but I failed with this error: $seconderror
1068 } if $seconderror;
1069             $mess .= qq{
1070 Please make sure the directory exists and is writable.
1071 };
1072             $CPAN::Frontend->mywarn($mess);
1073             return suggest_myconfig;
1074         }
1075     } # $@ after eval mkpath $dotcpan
1076     if (0) { # to test what happens when a race condition occurs
1077         for (reverse 1..10) {
1078             print $_, "\n";
1079             sleep 1;
1080         }
1081     }
1082     # locking
1083     if (!$RUN_DEGRADED && !$self->{LOCKFH}) {
1084         my $fh;
1085         unless ($fh = FileHandle->new("+>>$lockfile")) {
1086             if ($! =~ /Permission/) {
1087                 $CPAN::Frontend->mywarn(qq{
1088
1089 Your configuration suggests that CPAN.pm should use a working
1090 directory of
1091     $CPAN::Config->{cpan_home}
1092 Unfortunately we could not create the lock file
1093     $lockfile
1094 due to permission problems.
1095
1096 Please make sure that the configuration variable
1097     \$CPAN::Config->{cpan_home}
1098 points to a directory where you can write a .lock file. You can set
1099 this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
1100 \@INC path;
1101 });
1102                 return suggest_myconfig;
1103             }
1104         }
1105         my $sleep = 1;
1106         while (!CPAN::_flock($fh, LOCK_EX|LOCK_NB)) {
1107             if ($sleep>10) {
1108                 $CPAN::Frontend->mydie("Giving up\n");
1109             }
1110             $CPAN::Frontend->mysleep($sleep++);
1111             $CPAN::Frontend->mywarn("Could not lock lockfile with flock: $!; retrying\n");
1112         }
1113
1114         seek $fh, 0, 0;
1115         truncate $fh, 0;
1116         $fh->print($$, "\n");
1117         $fh->print(hostname(), "\n");
1118         $self->{LOCK} = $lockfile;
1119         $self->{LOCKFH} = $fh;
1120     }
1121     $SIG{TERM} = sub {
1122         my $sig = shift;
1123         &cleanup;
1124         $CPAN::Frontend->mydie("Got SIG$sig, leaving");
1125     };
1126     $SIG{INT} = sub {
1127       # no blocks!!!
1128         my $sig = shift;
1129         &cleanup if $Signal;
1130         die "Got yet another signal" if $Signal > 1;
1131         $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal;
1132         $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n");
1133         $Signal++;
1134     };
1135
1136 #       From: Larry Wall <larry@wall.org>
1137 #       Subject: Re: deprecating SIGDIE
1138 #       To: perl5-porters@perl.org
1139 #       Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
1140 #
1141 #       The original intent of __DIE__ was only to allow you to substitute one
1142 #       kind of death for another on an application-wide basis without respect
1143 #       to whether you were in an eval or not.  As a global backstop, it should
1144 #       not be used any more lightly (or any more heavily :-) than class
1145 #       UNIVERSAL.  Any attempt to build a general exception model on it should
1146 #       be politely squashed.  Any bug that causes every eval {} to have to be
1147 #       modified should be not so politely squashed.
1148 #
1149 #       Those are my current opinions.  It is also my optinion that polite
1150 #       arguments degenerate to personal arguments far too frequently, and that
1151 #       when they do, it's because both people wanted it to, or at least didn't
1152 #       sufficiently want it not to.
1153 #
1154 #       Larry
1155
1156     # global backstop to cleanup if we should really die
1157     $SIG{__DIE__} = \&cleanup;
1158     $self->debug("Signal handler set.") if $CPAN::DEBUG;
1159 }
1160
1161 #-> sub CPAN::DESTROY ;
1162 sub DESTROY {
1163     &cleanup; # need an eval?
1164 }
1165
1166 #-> sub CPAN::anycwd ;
1167 sub anycwd () {
1168     my $getcwd;
1169     $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
1170     CPAN->$getcwd();
1171 }
1172
1173 #-> sub CPAN::cwd ;
1174 sub cwd {Cwd::cwd();}
1175
1176 #-> sub CPAN::getcwd ;
1177 sub getcwd {Cwd::getcwd();}
1178
1179 #-> sub CPAN::fastcwd ;
1180 sub fastcwd {Cwd::fastcwd();}
1181
1182 #-> sub CPAN::backtickcwd ;
1183 sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
1184
1185 #-> sub CPAN::find_perl ;
1186 sub find_perl {
1187     my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
1188     my $pwd  = $CPAN::iCwd = CPAN::anycwd();
1189     my $candidate = File::Spec->catfile($pwd,$^X);
1190     $perl ||= $candidate if MM->maybe_command($candidate);
1191
1192     unless ($perl) {
1193         my ($component,$perl_name);
1194       DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
1195           PATH_COMPONENT: foreach $component (File::Spec->path(),
1196                                                 $Config::Config{'binexp'}) {
1197                 next unless defined($component) && $component;
1198                 my($abs) = File::Spec->catfile($component,$perl_name);
1199                 if (MM->maybe_command($abs)) {
1200                     $perl = $abs;
1201                     last DIST_PERLNAME;
1202                 }
1203             }
1204         }
1205     }
1206
1207     return $perl;
1208 }
1209
1210
1211 #-> sub CPAN::exists ;
1212 sub exists {
1213     my($mgr,$class,$id) = @_;
1214     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
1215     CPAN::Index->reload;
1216     ### Carp::croak "exists called without class argument" unless $class;
1217     $id ||= "";
1218     $id =~ s/:+/::/g if $class eq "CPAN::Module";
1219     my $exists;
1220     if (CPAN::_sqlite_running) {
1221         $exists = (exists $META->{readonly}{$class}{$id} or
1222                    $CPAN::SQLite->set($class, $id));
1223     } else {
1224         $exists =  exists $META->{readonly}{$class}{$id};
1225     }
1226     $exists ||= exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
1227 }
1228
1229 #-> sub CPAN::delete ;
1230 sub delete {
1231   my($mgr,$class,$id) = @_;
1232   delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
1233   delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
1234 }
1235
1236 #-> sub CPAN::has_usable
1237 # has_inst is sometimes too optimistic, we should replace it with this
1238 # has_usable whenever a case is given
1239 sub has_usable {
1240     my($self,$mod,$message) = @_;
1241     return 1 if $HAS_USABLE->{$mod};
1242     my $has_inst = $self->has_inst($mod,$message);
1243     return unless $has_inst;
1244     my $usable;
1245     $usable = {
1246                LWP => [ # we frequently had "Can't locate object
1247                         # method "new" via package "LWP::UserAgent" at
1248                         # (eval 69) line 2006
1249                        sub {require LWP},
1250                        sub {require LWP::UserAgent},
1251                        sub {require HTTP::Request},
1252                        sub {require URI::URL},
1253                       ],
1254                'Net::FTP' => [
1255                             sub {require Net::FTP},
1256                             sub {require Net::Config},
1257                            ],
1258                'File::HomeDir' => [
1259                                    sub {require File::HomeDir;
1260                                         unless (File::HomeDir::->VERSION >= 0.52) {
1261                                             for ("Will not use File::HomeDir, need 0.52\n") {
1262                                                 $CPAN::Frontend->mywarn($_);
1263                                                 die $_;
1264                                             }
1265                                         }
1266                                     },
1267                                   ],
1268                'Archive::Tar' => [
1269                                   sub {require Archive::Tar;
1270                                        unless (Archive::Tar::->VERSION >= 1.00) {
1271                                             for ("Will not use Archive::Tar, need 1.00\n") {
1272                                                 $CPAN::Frontend->mywarn($_);
1273                                                 die $_;
1274                                             }
1275                                        }
1276                                   },
1277                                  ],
1278               };
1279     if ($usable->{$mod}) {
1280         for my $c (0..$#{$usable->{$mod}}) {
1281             my $code = $usable->{$mod}[$c];
1282             my $ret = eval { &$code() };
1283             $ret = "" unless defined $ret;
1284             if ($@) {
1285                 # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
1286                 return;
1287             }
1288         }
1289     }
1290     return $HAS_USABLE->{$mod} = 1;
1291 }
1292
1293 #-> sub CPAN::has_inst
1294 sub has_inst {
1295     my($self,$mod,$message) = @_;
1296     Carp::croak("CPAN->has_inst() called without an argument")
1297         unless defined $mod;
1298     my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
1299         keys %{$CPAN::Config->{dontload_hash}||{}},
1300             @{$CPAN::Config->{dontload_list}||[]};
1301     if (defined $message && $message eq "no"  # afair only used by Nox
1302         ||
1303         $dont{$mod}
1304        ) {
1305       $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
1306       return 0;
1307     }
1308     my $file = $mod;
1309     my $obj;
1310     $file =~ s|::|/|g;
1311     $file .= ".pm";
1312     if ($INC{$file}) {
1313         # checking %INC is wrong, because $INC{LWP} may be true
1314         # although $INC{"URI/URL.pm"} may have failed. But as
1315         # I really want to say "bla loaded OK", I have to somehow
1316         # cache results.
1317         ### warn "$file in %INC"; #debug
1318         return 1;
1319     } elsif (eval { require $file }) {
1320         # eval is good: if we haven't yet read the database it's
1321         # perfect and if we have installed the module in the meantime,
1322         # it tries again. The second require is only a NOOP returning
1323         # 1 if we had success, otherwise it's retrying
1324
1325         my $mtime = (stat $INC{$file})[9];
1326         # privileged files loaded by has_inst; Note: we use $mtime
1327         # as a proxy for a checksum.
1328         $CPAN::Shell::reload->{$file} = $mtime;
1329         my $v = eval "\$$mod\::VERSION";
1330         $v = $v ? " (v$v)" : "";
1331         CPAN::Shell->optprint("load_module","CPAN: $mod loaded ok$v\n");
1332         if ($mod eq "CPAN::WAIT") {
1333             push @CPAN::Shell::ISA, 'CPAN::WAIT';
1334         }
1335         return 1;
1336     } elsif ($mod eq "Net::FTP") {
1337         $CPAN::Frontend->mywarn(qq{
1338   Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
1339   if you just type
1340       install Bundle::libnet
1341
1342 }) unless $Have_warned->{"Net::FTP"}++;
1343         $CPAN::Frontend->mysleep(3);
1344     } elsif ($mod eq "Digest::SHA") {
1345         if ($Have_warned->{"Digest::SHA"}++) {
1346             $CPAN::Frontend->mywarn(qq{CPAN: checksum security checks disabled }.
1347                                      qq{because Digest::SHA not installed.\n});
1348         } else {
1349             $CPAN::Frontend->mywarn(qq{
1350   CPAN: checksum security checks disabled because Digest::SHA not installed.
1351   Please consider installing the Digest::SHA module.
1352
1353 });
1354             $CPAN::Frontend->mysleep(2);
1355         }
1356     } elsif ($mod eq "Module::Signature") {
1357         # NOT prefs_lookup, we are not a distro
1358         my $check_sigs = $CPAN::Config->{check_sigs};
1359         if (not $check_sigs) {
1360             # they do not want us:-(
1361         } elsif (not $Have_warned->{"Module::Signature"}++) {
1362             # No point in complaining unless the user can
1363             # reasonably install and use it.
1364             if (eval { require Crypt::OpenPGP; 1 } ||
1365                 (
1366                  defined $CPAN::Config->{'gpg'}
1367                  &&
1368                  $CPAN::Config->{'gpg'} =~ /\S/
1369                 )
1370                ) {
1371                 $CPAN::Frontend->mywarn(qq{
1372   CPAN: Module::Signature security checks disabled because Module::Signature
1373   not installed.  Please consider installing the Module::Signature module.
1374   You may also need to be able to connect over the Internet to the public
1375   keyservers like pgp.mit.edu (port 11371).
1376
1377 });
1378                 $CPAN::Frontend->mysleep(2);
1379             }
1380         }
1381     } else {
1382         delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
1383     }
1384     return 0;
1385 }
1386
1387 #-> sub CPAN::instance ;
1388 sub instance {
1389     my($mgr,$class,$id) = @_;
1390     CPAN::Index->reload;
1391     $id ||= "";
1392     # unsafe meta access, ok?
1393     return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
1394     $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
1395 }
1396
1397 #-> sub CPAN::new ;
1398 sub new {
1399     bless {}, shift;
1400 }
1401
1402 #-> sub CPAN::cleanup ;
1403 sub cleanup {
1404   # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
1405   local $SIG{__DIE__} = '';
1406   my($message) = @_;
1407   my $i = 0;
1408   my $ineval = 0;
1409   my($subroutine);
1410   while ((undef,undef,undef,$subroutine) = caller(++$i)) {
1411       $ineval = 1, last if
1412         $subroutine eq '(eval)';
1413   }
1414   return if $ineval && !$CPAN::End;
1415   return unless defined $META->{LOCK};
1416   return unless -f $META->{LOCK};
1417   $META->savehist;
1418   close $META->{LOCKFH};
1419   unlink $META->{LOCK};
1420   # require Carp;
1421   # Carp::cluck("DEBUGGING");
1422   if ( $CPAN::CONFIG_DIRTY ) {
1423       $CPAN::Frontend->mywarn("Warning: Configuration not saved.\n");
1424   }
1425   $CPAN::Frontend->myprint("Lockfile removed.\n");
1426 }
1427
1428 #-> sub CPAN::readhist
1429 sub readhist {
1430     my($self,$term,$histfile) = @_;
1431     my($fh) = FileHandle->new;
1432     open $fh, "<$histfile" or last;
1433     local $/ = "\n";
1434     while (<$fh>) {
1435         chomp;
1436         $term->AddHistory($_);
1437     }
1438     close $fh;
1439 }
1440
1441 #-> sub CPAN::savehist
1442 sub savehist {
1443     my($self) = @_;
1444     my($histfile,$histsize);
1445     unless ($histfile = $CPAN::Config->{'histfile'}) {
1446         $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
1447         return;
1448     }
1449     $histsize = $CPAN::Config->{'histsize'} || 100;
1450     if ($CPAN::term) {
1451         unless ($CPAN::term->can("GetHistory")) {
1452             $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
1453             return;
1454         }
1455     } else {
1456         return;
1457     }
1458     my @h = $CPAN::term->GetHistory;
1459     splice @h, 0, @h-$histsize if @h>$histsize;
1460     my($fh) = FileHandle->new;
1461     open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
1462     local $\ = local $, = "\n";
1463     print $fh @h;
1464     close $fh;
1465 }
1466
1467 #-> sub CPAN::is_tested
1468 sub is_tested {
1469     my($self,$what,$when) = @_;
1470     unless ($what) {
1471         Carp::cluck("DEBUG: empty what");
1472         return;
1473     }
1474     $self->{is_tested}{$what} = $when;
1475 }
1476
1477 #-> sub CPAN::is_installed
1478 # unsets the is_tested flag: as soon as the thing is installed, it is
1479 # not needed in set_perl5lib anymore
1480 sub is_installed {
1481     my($self,$what) = @_;
1482     delete $self->{is_tested}{$what};
1483 }
1484
1485 sub _list_sorted_descending_is_tested {
1486     my($self) = @_;
1487     sort
1488         { ($self->{is_tested}{$b}||0) <=> ($self->{is_tested}{$a}||0) }
1489             keys %{$self->{is_tested}}
1490 }
1491
1492 #-> sub CPAN::set_perl5lib
1493 sub set_perl5lib {
1494     my($self,$for) = @_;
1495     unless ($for) {
1496         (undef,undef,undef,$for) = caller(1);
1497         $for =~ s/.*://;
1498     }
1499     $self->{is_tested} ||= {};
1500     return unless %{$self->{is_tested}};
1501     my $env = $ENV{PERL5LIB};
1502     $env = $ENV{PERLLIB} unless defined $env;
1503     my @env;
1504     push @env, $env if defined $env and length $env;
1505     #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
1506     #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
1507
1508     my @dirs = map {("$_/blib/arch", "$_/blib/lib")} $self->_list_sorted_descending_is_tested;
1509     if (@dirs < 12) {
1510         $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB for '$for'\n");
1511     } elsif (@dirs < 24) {
1512         my @d = map {my $cp = $_;
1513                      $cp =~ s/^\Q$CPAN::Config->{build_dir}\E/%BUILDDIR%/;
1514                      $cp
1515                  } @dirs;
1516         $CPAN::Frontend->myprint("Prepending @d to PERL5LIB; ".
1517                                  "%BUILDDIR%=$CPAN::Config->{build_dir} ".
1518                                  "for '$for'\n"
1519                                 );
1520     } else {
1521         my $cnt = keys %{$self->{is_tested}};
1522         $CPAN::Frontend->myprint("Prepending blib/arch and blib/lib of ".
1523                                  "$cnt build dirs to PERL5LIB; ".
1524                                  "for '$for'\n"
1525                                 );
1526     }
1527
1528     $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1529 }
1530
1531 package CPAN::CacheMgr;
1532 use strict;
1533
1534 #-> sub CPAN::CacheMgr::as_string ;
1535 sub as_string {
1536     eval { require Data::Dumper };
1537     if ($@) {
1538         return shift->SUPER::as_string;
1539     } else {
1540         return Data::Dumper::Dumper(shift);
1541     }
1542 }
1543
1544 #-> sub CPAN::CacheMgr::cachesize ;
1545 sub cachesize {
1546     shift->{DU};
1547 }
1548
1549 #-> sub CPAN::CacheMgr::tidyup ;
1550 sub tidyup {
1551   my($self) = @_;
1552   return unless $CPAN::META->{LOCK};
1553   return unless -d $self->{ID};
1554   my @toremove = grep { $self->{SIZE}{$_}==0 } @{$self->{FIFO}};
1555   for my $current (0..$#toremove) {
1556     my $toremove = $toremove[$current];
1557     $CPAN::Frontend->myprint(sprintf(
1558                                      "DEL(%d/%d): %s \n",
1559                                      $current+1,
1560                                      scalar @toremove,
1561                                      $toremove,
1562                                     )
1563                             );
1564     return if $CPAN::Signal;
1565     $self->_clean_cache($toremove);
1566     return if $CPAN::Signal;
1567   }
1568 }
1569
1570 #-> sub CPAN::CacheMgr::dir ;
1571 sub dir {
1572     shift->{ID};
1573 }
1574
1575 #-> sub CPAN::CacheMgr::entries ;
1576 sub entries {
1577     my($self,$dir) = @_;
1578     return unless defined $dir;
1579     $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
1580     $dir ||= $self->{ID};
1581     my($cwd) = CPAN::anycwd();
1582     chdir $dir or Carp::croak("Can't chdir to $dir: $!");
1583     my $dh = DirHandle->new(File::Spec->curdir)
1584         or Carp::croak("Couldn't opendir $dir: $!");
1585     my(@entries);
1586     for ($dh->read) {
1587         next if $_ eq "." || $_ eq "..";
1588         if (-f $_) {
1589             push @entries, File::Spec->catfile($dir,$_);
1590         } elsif (-d _) {
1591             push @entries, File::Spec->catdir($dir,$_);
1592         } else {
1593             $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
1594         }
1595     }
1596     chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
1597     sort { -M $a <=> -M $b} @entries;
1598 }
1599
1600 #-> sub CPAN::CacheMgr::disk_usage ;
1601 sub disk_usage {
1602     my($self,$dir,$fast) = @_;
1603     return if exists $self->{SIZE}{$dir};
1604     return if $CPAN::Signal;
1605     my($Du) = 0;
1606     if (-e $dir) {
1607         if (-d $dir) {
1608             unless (-x $dir) {
1609                 unless (chmod 0755, $dir) {
1610                     $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
1611                                             "permission to change the permission; cannot ".
1612                                             "estimate disk usage of '$dir'\n");
1613                     $CPAN::Frontend->mysleep(5);
1614                     return;
1615                 }
1616             }
1617         } elsif (-f $dir) {
1618             # nothing to say, no matter what the permissions
1619         }
1620     } else {
1621         $CPAN::Frontend->mywarn("File or directory '$dir' has gone, ignoring\n");
1622         return;
1623     }
1624     if ($fast) {
1625         $Du = 0; # placeholder
1626     } else {
1627         find(
1628              sub {
1629            $File::Find::prune++ if $CPAN::Signal;
1630            return if -l $_;
1631            if ($^O eq 'MacOS') {
1632              require Mac::Files;
1633              my $cat  = Mac::Files::FSpGetCatInfo($_);
1634              $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
1635            } else {
1636              if (-d _) {
1637                unless (-x _) {
1638                  unless (chmod 0755, $_) {
1639                    $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
1640                                            "the permission to change the permission; ".
1641                                            "can only partially estimate disk usage ".
1642                                            "of '$_'\n");
1643                    $CPAN::Frontend->mysleep(5);
1644                    return;
1645                  }
1646                }
1647              } else {
1648                $Du += (-s _);
1649              }
1650            }
1651          },
1652          $dir
1653             );
1654     }
1655     return if $CPAN::Signal;
1656     $self->{SIZE}{$dir} = $Du/1024/1024;
1657     unshift @{$self->{FIFO}}, $dir;
1658     $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
1659     $self->{DU} += $Du/1024/1024;
1660     $self->{DU};
1661 }
1662
1663 #-> sub CPAN::CacheMgr::_clean_cache ;
1664 sub _clean_cache {
1665     my($self,$dir) = @_;
1666     return unless -e $dir;
1667     unless (File::Spec->canonpath(File::Basename::dirname($dir))
1668             eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
1669         $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
1670                                 "will not remove\n");
1671         $CPAN::Frontend->mysleep(5);
1672         return;
1673     }
1674     $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
1675         if $CPAN::DEBUG;
1676     File::Path::rmtree($dir);
1677     my $id_deleted = 0;
1678     if ($dir !~ /\.yml$/ && -f "$dir.yml") {
1679         my $yaml_module = CPAN::_yaml_module;
1680         if ($CPAN::META->has_inst($yaml_module)) {
1681             my($peek_yaml) = eval { CPAN->_yaml_loadfile("$dir.yml"); };
1682             if ($@) {
1683                 $CPAN::Frontend->mywarn("(parse error on '$dir.yml' removing anyway)");
1684                 unlink "$dir.yml" or
1685                     $CPAN::Frontend->mywarn("(Could not unlink '$dir.yml': $!)");
1686                 return;
1687             } elsif (my $id = $peek_yaml->[0]{distribution}{ID}) {
1688                 $CPAN::META->delete("CPAN::Distribution", $id);
1689
1690                 # XXX we should restore the state NOW, otherise this
1691                 # distro does not exist until we read an index. BUG ALERT(?)
1692
1693                 # $CPAN::Frontend->mywarn (" +++\n");
1694                 $id_deleted++;
1695             }
1696         }
1697         unlink "$dir.yml"; # may fail
1698         unless ($id_deleted) {
1699             CPAN->debug("no distro found associated with '$dir'");
1700         }
1701     }
1702     $self->{DU} -= $self->{SIZE}{$dir};
1703     delete $self->{SIZE}{$dir};
1704 }
1705
1706 #-> sub CPAN::CacheMgr::new ;
1707 sub new {
1708     my $class = shift;
1709     my $time = time;
1710     my($debug,$t2);
1711     $debug = "";
1712     my $self = {
1713         ID => $CPAN::Config->{build_dir},
1714         MAX => $CPAN::Config->{'build_cache'},
1715         SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
1716         DU => 0
1717     };
1718     File::Path::mkpath($self->{ID});
1719     my $dh = DirHandle->new($self->{ID});
1720     bless $self, $class;
1721     $self->scan_cache;
1722     $t2 = time;
1723     $debug .= "timing of CacheMgr->new: ".($t2 - $time);
1724     $time = $t2;
1725     CPAN->debug($debug) if $CPAN::DEBUG;
1726     $self;
1727 }
1728
1729 #-> sub CPAN::CacheMgr::scan_cache ;
1730 sub scan_cache {
1731     my $self = shift;
1732     return if $self->{SCAN} eq 'never';
1733     $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
1734         unless $self->{SCAN} eq 'atstart';
1735     return unless $CPAN::META->{LOCK};
1736     $CPAN::Frontend->myprint(
1737                              sprintf("Scanning cache %s for sizes\n",
1738                              $self->{ID}));
1739     my $e;
1740     my @entries = $self->entries($self->{ID});
1741     my $i = 0;
1742     my $painted = 0;
1743     for $e (@entries) {
1744         my $symbol = ".";
1745         if ($self->{DU} > $self->{MAX}) {
1746             $symbol = "-";
1747             $self->disk_usage($e,1);
1748         } else {
1749             $self->disk_usage($e);
1750         }
1751         $i++;
1752         while (($painted/76) < ($i/@entries)) {
1753             $CPAN::Frontend->myprint($symbol);
1754             $painted++;
1755         }
1756         return if $CPAN::Signal;
1757     }
1758     $CPAN::Frontend->myprint("DONE\n");
1759     $self->tidyup;
1760 }
1761
1762 package CPAN::Shell;
1763 use strict;
1764
1765 #-> sub CPAN::Shell::h ;
1766 sub h {
1767     my($class,$about) = @_;
1768     if (defined $about) {
1769         my $help;
1770         if (exists $Help->{$about}) {
1771             if (ref $Help->{$about}) { # aliases
1772                 $about = ${$Help->{$about}};
1773             }
1774             $help = $Help->{$about};
1775         } else {
1776             $help = "No help available";
1777         }
1778         $CPAN::Frontend->myprint("$about\: $help\n");
1779     } else {
1780         my $filler = " " x (80 - 28 - length($CPAN::VERSION));
1781         $CPAN::Frontend->myprint(qq{
1782 Display Information $filler (ver $CPAN::VERSION)
1783  command  argument          description
1784  a,b,d,m  WORD or /REGEXP/  about authors, bundles, distributions, modules
1785  i        WORD or /REGEXP/  about any of the above
1786  ls       AUTHOR or GLOB    about files in the author's directory
1787     (with WORD being a module, bundle or author name or a distribution
1788     name of the form AUTHOR/DISTRIBUTION)
1789
1790 Download, Test, Make, Install...
1791  get      download                     clean    make clean
1792  make     make (implies get)           look     open subshell in dist directory
1793  test     make test (implies make)     readme   display these README files
1794  install  make install (implies test)  perldoc  display POD documentation
1795
1796 Upgrade
1797  r        WORDs or /REGEXP/ or NONE    report updates for some/matching/all modules
1798  upgrade  WORDs or /REGEXP/ or NONE    upgrade some/matching/all modules
1799
1800 Pragmas
1801  force  CMD    try hard to do command  fforce CMD    try harder
1802  notest CMD    skip testing
1803
1804 Other
1805  h,?           display this menu       ! perl-code   eval a perl command
1806  o conf [opt]  set and query options   q             quit the cpan shell
1807  reload cpan   load CPAN.pm again      reload index  load newer indices
1808  autobundle    Snapshot                recent        latest CPAN uploads});
1809 }
1810 }
1811
1812 *help = \&h;
1813
1814 #-> sub CPAN::Shell::a ;
1815 sub a {
1816   my($self,@arg) = @_;
1817   # authors are always UPPERCASE
1818   for (@arg) {
1819     $_ = uc $_ unless /=/;
1820   }
1821   $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1822 }
1823
1824 #-> sub CPAN::Shell::globls ;
1825 sub globls {
1826     my($self,$s,$pragmas) = @_;
1827     # ls is really very different, but we had it once as an ordinary
1828     # command in the Shell (upto rev. 321) and we could not handle
1829     # force well then
1830     my(@accept,@preexpand);
1831     if ($s =~ /[\*\?\/]/) {
1832         if ($CPAN::META->has_inst("Text::Glob")) {
1833             if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
1834                 my $rau = Text::Glob::glob_to_regex(uc $au);
1835                 CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
1836                       if $CPAN::DEBUG;
1837                 push @preexpand, map { $_->id . "/" . $pathglob }
1838                     CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
1839             } else {
1840                 my $rau = Text::Glob::glob_to_regex(uc $s);
1841                 push @preexpand, map { $_->id }
1842                     CPAN::Shell->expand_by_method('CPAN::Author',
1843                                                   ['id'],
1844                                                   "/$rau/");
1845             }
1846         } else {
1847             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
1848         }
1849     } else {
1850         push @preexpand, uc $s;
1851     }
1852     for (@preexpand) {
1853         unless (/^[A-Z0-9\-]+(\/|$)/i) {
1854             $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
1855             next;
1856         }
1857         push @accept, $_;
1858     }
1859     my $silent = @accept>1;
1860     my $last_alpha = "";
1861     my @results;
1862     for my $a (@accept) {
1863         my($author,$pathglob);
1864         if ($a =~ m|(.*?)/(.*)|) {
1865             my $a2 = $1;
1866             $pathglob = $2;
1867             $author = CPAN::Shell->expand_by_method('CPAN::Author',
1868                                                     ['id'],
1869                                                     $a2)
1870                 or $CPAN::Frontend->mydie("No author found for $a2\n");
1871         } else {
1872             $author = CPAN::Shell->expand_by_method('CPAN::Author',
1873                                                     ['id'],
1874                                                     $a)
1875                 or $CPAN::Frontend->mydie("No author found for $a\n");
1876         }
1877         if ($silent) {
1878             my $alpha = substr $author->id, 0, 1;
1879             my $ad;
1880             if ($alpha eq $last_alpha) {
1881                 $ad = "";
1882             } else {
1883                 $ad = "[$alpha]";
1884                 $last_alpha = $alpha;
1885             }
1886             $CPAN::Frontend->myprint($ad);
1887         }
1888         for my $pragma (@$pragmas) {
1889             if ($author->can($pragma)) {
1890                 $author->$pragma();
1891             }
1892         }
1893         push @results, $author->ls($pathglob,$silent); # silent if
1894                                                        # more than one
1895                                                        # author
1896         for my $pragma (@$pragmas) {
1897             my $unpragma = "un$pragma";
1898             if ($author->can($unpragma)) {
1899                 $author->$unpragma();
1900             }
1901         }
1902     }
1903     @results;
1904 }
1905
1906 #-> sub CPAN::Shell::local_bundles ;
1907 sub local_bundles {
1908     my($self,@which) = @_;
1909     my($incdir,$bdir,$dh);
1910     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1911         my @bbase = "Bundle";
1912         while (my $bbase = shift @bbase) {
1913             $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
1914             CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1915             if ($dh = DirHandle->new($bdir)) { # may fail
1916                 my($entry);
1917                 for $entry ($dh->read) {
1918                     next if $entry =~ /^\./;
1919                     next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/;
1920                     if (-d File::Spec->catdir($bdir,$entry)) {
1921                         push @bbase, "$bbase\::$entry";
1922                     } else {
1923                         next unless $entry =~ s/\.pm(?!\n)\Z//;
1924                         $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1925                     }
1926                 }
1927             }
1928         }
1929     }
1930 }
1931
1932 #-> sub CPAN::Shell::b ;
1933 sub b {
1934     my($self,@which) = @_;
1935     CPAN->debug("which[@which]") if $CPAN::DEBUG;
1936     $self->local_bundles;
1937     $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1938 }
1939
1940 #-> sub CPAN::Shell::d ;
1941 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1942
1943 #-> sub CPAN::Shell::m ;
1944 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1945     my $self = shift;
1946     $CPAN::Frontend->myprint($self->format_result('Module',@_));
1947 }
1948
1949 #-> sub CPAN::Shell::i ;
1950 sub i {
1951     my($self) = shift;
1952     my(@args) = @_;
1953     @args = '/./' unless @args;
1954     my(@result);
1955     for my $type (qw/Bundle Distribution Module/) {
1956         push @result, $self->expand($type,@args);
1957     }
1958     # Authors are always uppercase.
1959     push @result, $self->expand("Author", map { uc $_ } @args);
1960
1961     my $result = @result == 1 ?
1962         $result[0]->as_string :
1963             @result == 0 ?
1964                 "No objects found of any type for argument @args\n" :
1965                     join("",
1966                          (map {$_->as_glimpse} @result),
1967                          scalar @result, " items found\n",
1968                         );
1969     $CPAN::Frontend->myprint($result);
1970 }
1971
1972 #-> sub CPAN::Shell::o ;
1973
1974 # CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o
1975 # conf' calls through to CPAN::HandleConfig::edit. 'o conf' should
1976 # probably have been called 'set' and 'o debug' maybe 'set debug' or
1977 # 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm
1978 sub o {
1979     my($self,$o_type,@o_what) = @_;
1980     $o_type ||= "";
1981     CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1982     if ($o_type eq 'conf') {
1983         my($cfilter) = $o_what[0] =~ m|^/(.*)/$|;
1984         if (!@o_what or $cfilter) { # print all things, "o conf"
1985             $cfilter ||= "";
1986             my $qrfilter = eval 'qr/$cfilter/';
1987             my($k,$v);
1988             $CPAN::Frontend->myprint("\$CPAN::Config options from ");
1989             my @from;
1990             if (exists $INC{'CPAN/Config.pm'}) {
1991                 push @from, $INC{'CPAN/Config.pm'};
1992             }
1993             if (exists $INC{'CPAN/MyConfig.pm'}) {
1994                 push @from, $INC{'CPAN/MyConfig.pm'};
1995             }
1996             $CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from);
1997             $CPAN::Frontend->myprint(":\n");
1998             for $k (sort keys %CPAN::HandleConfig::can) {
1999                 next unless $k =~ /$qrfilter/;
2000                 $v = $CPAN::HandleConfig::can{$k};
2001                 $CPAN::Frontend->myprint(sprintf "    %-18s [%s]\n", $k, $v);
2002             }
2003             $CPAN::Frontend->myprint("\n");
2004             for $k (sort keys %CPAN::HandleConfig::keys) {
2005                 next unless $k =~ /$qrfilter/;
2006                 CPAN::HandleConfig->prettyprint($k);
2007             }
2008             $CPAN::Frontend->myprint("\n");
2009         } else {
2010             if (CPAN::HandleConfig->edit(@o_what)) {
2011             } else {
2012                 $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
2013                                          qq{items\n\n});
2014             }
2015         }
2016     } elsif ($o_type eq 'debug') {
2017         my(%valid);
2018         @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
2019         if (@o_what) {
2020             while (@o_what) {
2021                 my($what) = shift @o_what;
2022                 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
2023                     $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
2024                     next;
2025                 }
2026                 if ( exists $CPAN::DEBUG{$what} ) {
2027                     $CPAN::DEBUG |= $CPAN::DEBUG{$what};
2028                 } elsif ($what =~ /^\d/) {
2029                     $CPAN::DEBUG = $what;
2030                 } elsif (lc $what eq 'all') {
2031                     my($max) = 0;
2032                     for (values %CPAN::DEBUG) {
2033                         $max += $_;
2034                     }
2035                     $CPAN::DEBUG = $max;
2036                 } else {
2037                     my($known) = 0;
2038                     for (keys %CPAN::DEBUG) {
2039                         next unless lc($_) eq lc($what);
2040                         $CPAN::DEBUG |= $CPAN::DEBUG{$_};
2041                         $known = 1;
2042                     }
2043                     $CPAN::Frontend->myprint("unknown argument [$what]\n")
2044                         unless $known;
2045                 }
2046             }
2047         } else {
2048             my $raw = "Valid options for debug are ".
2049                 join(", ",sort(keys %CPAN::DEBUG), 'all').
2050                      qq{ or a number. Completion works on the options. }.
2051                      qq{Case is ignored.};
2052             require Text::Wrap;
2053             $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
2054             $CPAN::Frontend->myprint("\n\n");
2055         }
2056         if ($CPAN::DEBUG) {
2057             $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n");
2058             my($k,$v);
2059             for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
2060                 $v = $CPAN::DEBUG{$k};
2061                 $CPAN::Frontend->myprint(sprintf "    %-14s(%s)\n", $k, $v)
2062                     if $v & $CPAN::DEBUG;
2063             }
2064         } else {
2065             $CPAN::Frontend->myprint("Debugging turned off completely.\n");
2066         }
2067     } else {
2068         $CPAN::Frontend->myprint(qq{
2069 Known options:
2070   conf    set or get configuration variables
2071   debug   set or get debugging options
2072 });
2073     }
2074 }
2075
2076 # CPAN::Shell::paintdots_onreload
2077 sub paintdots_onreload {
2078     my($ref) = shift;
2079     sub {
2080         if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
2081             my($subr) = $1;
2082             ++$$ref;
2083             local($|) = 1;
2084             # $CPAN::Frontend->myprint(".($subr)");
2085             $CPAN::Frontend->myprint(".");
2086             if ($subr =~ /\bshell\b/i) {
2087                 # warn "debug[$_[0]]";
2088
2089                 # It would be nice if we could detect that a
2090                 # subroutine has actually changed, but for now we
2091                 # practically always set the GOTOSHELL global
2092
2093                 $CPAN::GOTOSHELL=1;
2094             }
2095             return;
2096         }
2097         warn @_;
2098     };
2099 }
2100
2101 #-> sub CPAN::Shell::hosts ;
2102 sub hosts {
2103     my($self) = @_;
2104     my $fullstats = CPAN::FTP->_ftp_statistics();
2105     my $history = $fullstats->{history} || [];
2106     my %S; # statistics
2107     while (my $last = pop @$history) {
2108         my $attempts = $last->{attempts} or next;
2109         my $start;
2110         if (@$attempts) {
2111             $start = $attempts->[-1]{start};
2112             if ($#$attempts > 0) {
2113                 for my $i (0..$#$attempts-1) {
2114                     my $url = $attempts->[$i]{url} or next;
2115                     $S{no}{$url}++;
2116                 }
2117             }
2118         } else {
2119             $start = $last->{start};
2120         }
2121         next unless $last->{thesiteurl}; # C-C? bad filenames?
2122         $S{start} = $start;
2123         $S{end} ||= $last->{end};
2124         my $dltime = $last->{end} - $start;
2125         my $dlsize = $last->{filesize} || 0;
2126         my $url = ref $last->{thesiteurl} ? $last->{thesiteurl}->text : $last->{thesiteurl};
2127         my $s = $S{ok}{$url} ||= {};
2128         $s->{n}++;
2129         $s->{dlsize} ||= 0;
2130         $s->{dlsize} += $dlsize/1024;
2131         $s->{dltime} ||= 0;
2132         $s->{dltime} += $dltime;
2133     }
2134     my $res;
2135     for my $url (keys %{$S{ok}}) {
2136         next if $S{ok}{$url}{dltime} == 0; # div by zero
2137         push @{$res->{ok}}, [@{$S{ok}{$url}}{qw(n dlsize dltime)},
2138                              $S{ok}{$url}{dlsize}/$S{ok}{$url}{dltime},
2139                              $url,
2140                             ];
2141     }
2142     for my $url (keys %{$S{no}}) {
2143         push @{$res->{no}}, [$S{no}{$url},
2144                              $url,
2145                             ];
2146     }
2147     my $R = ""; # report
2148     if ($S{start} && $S{end}) {
2149         $R .= sprintf "Log starts: %s\n", $S{start} ? scalar(localtime $S{start}) : "unknown";
2150         $R .= sprintf "Log ends  : %s\n", $S{end}   ? scalar(localtime $S{end})   : "unknown";
2151     }
2152     if ($res->{ok} && @{$res->{ok}}) {
2153         $R .= sprintf "\nSuccessful downloads:
2154    N       kB  secs      kB/s url\n";
2155         my $i = 20;
2156         for (sort { $b->[3] <=> $a->[3] } @{$res->{ok}}) {
2157             $R .= sprintf "%4d %8d %5d %9.1f %s\n", @$_;
2158             last if --$i<=0;
2159         }
2160     }
2161     if ($res->{no} && @{$res->{no}}) {
2162         $R .= sprintf "\nUnsuccessful downloads:\n";
2163         my $i = 20;
2164         for (sort { $b->[0] <=> $a->[0] } @{$res->{no}}) {
2165             $R .= sprintf "%4d %s\n", @$_;
2166             last if --$i<=0;
2167         }
2168     }
2169     $CPAN::Frontend->myprint($R);
2170 }
2171
2172 #-> sub CPAN::Shell::reload ;
2173 sub reload {
2174     my($self,$command,@arg) = @_;
2175     $command ||= "";
2176     $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
2177     if ($command =~ /^cpan$/i) {
2178         my $redef = 0;
2179         chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
2180         my $failed;
2181         my @relo = (
2182                     "CPAN.pm",
2183                     "CPAN/Debug.pm",
2184                     "CPAN/FirstTime.pm",
2185                     "CPAN/HandleConfig.pm",
2186                     "CPAN/Kwalify.pm",
2187                     "CPAN/Queue.pm",
2188                     "CPAN/Reporter/Config.pm",
2189                     "CPAN/Reporter/History.pm",
2190                     "CPAN/Reporter.pm",
2191                     "CPAN/SQLite.pm",
2192                     "CPAN/Tarzip.pm",
2193                     "CPAN/Version.pm",
2194                    );
2195       MFILE: for my $f (@relo) {
2196             next unless exists $INC{$f};
2197             my $p = $f;
2198             $p =~ s/\.pm$//;
2199             $p =~ s|/|::|g;
2200             $CPAN::Frontend->myprint("($p");
2201             local($SIG{__WARN__}) = paintdots_onreload(\$redef);
2202             $self->_reload_this($f) or $failed++;
2203             my $v = eval "$p\::->VERSION";
2204             $CPAN::Frontend->myprint("v$v)");
2205         }
2206         $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
2207         if ($failed) {
2208             my $errors = $failed == 1 ? "error" : "errors";
2209             $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ".
2210                                     "this session.\n");
2211         }
2212     } elsif ($command =~ /^index$/i) {
2213       CPAN::Index->force_reload;
2214     } else {
2215       $CPAN::Frontend->myprint(qq{cpan     re-evals the CPAN modules
2216 index    re-reads the index files\n});
2217     }
2218 }
2219
2220 # reload means only load again what we have loaded before
2221 #-> sub CPAN::Shell::_reload_this ;
2222 sub _reload_this {
2223     my($self,$f,$args) = @_;
2224     CPAN->debug("f[$f]") if $CPAN::DEBUG;
2225     return 1 unless $INC{$f}; # we never loaded this, so we do not
2226                               # reload but say OK
2227     my $pwd = CPAN::anycwd();
2228     CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG;
2229     my($file);
2230     for my $inc (@INC) {
2231         $file = File::Spec->catfile($inc,split /\//, $f);
2232         last if -f $file;
2233         $file = "";
2234     }
2235     CPAN->debug("file[$file]") if $CPAN::DEBUG;
2236     my @inc = @INC;
2237     unless ($file && -f $file) {
2238         # this thingie is not in the INC path, maybe CPAN/MyConfig.pm?
2239         $file = $INC{$f};
2240         unless (CPAN->has_inst("File::Basename")) {
2241             @inc = File::Basename::dirname($file);
2242         } else {
2243             # do we ever need this?
2244             @inc = substr($file,0,-length($f)-1); # bring in back to me!
2245         }
2246     }
2247     CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG;
2248     unless (-f $file) {
2249         $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
2250         return;
2251     }
2252     my $mtime = (stat $file)[9];
2253     if ($reload->{$f}) {
2254     } elsif ($^T < $mtime) {
2255         # since we started the file has changed, force it to be reloaded
2256         $reload->{$f} = -1;
2257     } else {
2258         $reload->{$f} = $mtime;
2259     }
2260     my $must_reload = $mtime != $reload->{$f};
2261     $args ||= {};
2262     $must_reload ||= $args->{reloforce}; # o conf defaults needs this
2263     if ($must_reload) {
2264         my $fh = FileHandle->new($file) or
2265             $CPAN::Frontend->mydie("Could not open $file: $!");
2266         local($/);
2267         local $^W = 1;
2268         my $content = <$fh>;
2269         CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
2270             if $CPAN::DEBUG;
2271         delete $INC{$f};
2272         local @INC = @inc;
2273         eval "require '$f'";
2274         if ($@) {
2275             warn $@;
2276             return;
2277         }
2278         $reload->{$f} = $mtime;
2279     } else {
2280         $CPAN::Frontend->myprint("__unchanged__");
2281     }
2282     return 1;
2283 }
2284
2285 #-> sub CPAN::Shell::mkmyconfig ;
2286 sub mkmyconfig {
2287     my($self, $cpanpm, %args) = @_;
2288     require CPAN::FirstTime;
2289     my $home = CPAN::HandleConfig::home;
2290     $cpanpm = $INC{'CPAN/MyConfig.pm'} ||
2291         File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm");
2292     File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm;
2293     CPAN::HandleConfig::require_myconfig_or_config;
2294     $CPAN::Config ||= {};
2295     $CPAN::Config = {
2296         %$CPAN::Config,
2297         build_dir           =>  undef,
2298         cpan_home           =>  undef,
2299         keep_source_where   =>  undef,
2300         histfile            =>  undef,
2301     };
2302     CPAN::FirstTime::init($cpanpm, %args);
2303 }
2304
2305 #-> sub CPAN::Shell::_binary_extensions ;
2306 sub _binary_extensions {
2307     my($self) = shift @_;
2308     my(@result,$module,%seen,%need,$headerdone);
2309     for $module ($self->expand('Module','/./')) {
2310         my $file  = $module->cpan_file;
2311         next if $file eq "N/A";
2312         next if $file =~ /^Contact Author/;
2313         my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
2314         next if $dist->isa_perl;
2315         next unless $module->xs_file;
2316         local($|) = 1;
2317         $CPAN::Frontend->myprint(".");
2318         push @result, $module;
2319     }
2320 #    print join " | ", @result;
2321     $CPAN::Frontend->myprint("\n");
2322     return @result;
2323 }
2324
2325 #-> sub CPAN::Shell::recompile ;
2326 sub recompile {
2327     my($self) = shift @_;
2328     my($module,@module,$cpan_file,%dist);
2329     @module = $self->_binary_extensions();
2330     for $module (@module) { # we force now and compile later, so we
2331                             # don't do it twice
2332         $cpan_file = $module->cpan_file;
2333         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
2334         $pack->force;
2335         $dist{$cpan_file}++;
2336     }
2337     for $cpan_file (sort keys %dist) {
2338         $CPAN::Frontend->myprint("  CPAN: Recompiling $cpan_file\n\n");
2339         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
2340         $pack->install;
2341         $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
2342                            # stop a package from recompiling,
2343                            # e.g. IO-1.12 when we have perl5.003_10
2344     }
2345 }
2346
2347 #-> sub CPAN::Shell::scripts ;
2348 sub scripts {
2349     my($self, $arg) = @_;
2350     $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");
2351
2352     for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) {
2353         unless ($CPAN::META->has_inst($req)) {
2354             $CPAN::Frontend->mywarn("  $req not available\n");
2355         }
2356     }
2357     my $p = HTML::LinkExtor->new();
2358     my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html";
2359     unless (-f $indexfile) {
2360         $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n");
2361     }
2362     $p->parse_file($indexfile);
2363     my @hrefs;
2364     my $qrarg;
2365     if ($arg =~ s|^/(.+)/$|$1|) {
2366         $qrarg = eval 'qr/$arg/'; # hide construct from 5.004
2367     }
2368     for my $l ($p->links) {
2369         my $tag = shift @$l;
2370         next unless $tag eq "a";
2371         my %att = @$l;
2372         my $href = $att{href};
2373         next unless $href =~ s|^\.\./authors/id/./../||;
2374         if ($arg) {
2375             if ($qrarg) {
2376                 if ($href =~ $qrarg) {
2377                     push @hrefs, $href;
2378                 }
2379             } else {
2380                 if ($href =~ /\Q$arg\E/) {
2381                     push @hrefs, $href;
2382                 }
2383             }
2384         } else {
2385             push @hrefs, $href;
2386         }
2387     }
2388     # now filter for the latest version if there is more than one of a name
2389     my %stems;
2390     for (sort @hrefs) {
2391         my $href = $_;
2392         s/-v?\d.*//;
2393         my $stem = $_;
2394         $stems{$stem} ||= [];
2395         push @{$stems{$stem}}, $href;
2396     }
2397     for (sort keys %stems) {
2398         my $highest;
2399         if (@{$stems{$_}} > 1) {
2400             $highest = List::Util::reduce {
2401                 Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b
2402               } @{$stems{$_}};
2403         } else {
2404             $highest = $stems{$_}[0];
2405         }
2406         $CPAN::Frontend->myprint("$highest\n");
2407     }
2408 }
2409
2410 #-> sub CPAN::Shell::report ;
2411 sub report {
2412     my($self,@args) = @_;
2413     unless ($CPAN::META->has_inst("CPAN::Reporter")) {
2414         $CPAN::Frontend->mydie("CPAN::Reporter not installed; cannot continue");
2415     }
2416     local $CPAN::Config->{test_report} = 1;
2417     $self->force("test",@args); # force is there so that the test be
2418                                 # re-run (as documented)
2419 }
2420
2421 # compare with is_tested
2422 #-> sub CPAN::Shell::install_tested
2423 sub install_tested {
2424     my($self,@some) = @_;
2425     $CPAN::Frontend->mywarn("install_tested() must not be called with arguments.\n"),
2426         return if @some;
2427     CPAN::Index->reload;
2428
2429     for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
2430         my $yaml = "$b.yml";
2431         unless (-f $yaml) {
2432             $CPAN::Frontend->mywarn("No YAML file for $b available, skipping\n");
2433             next;
2434         }
2435         my $yaml_content = CPAN->_yaml_loadfile($yaml);
2436         my $id = $yaml_content->[0]{distribution}{ID};
2437         unless ($id) {
2438             $CPAN::Frontend->mywarn("No ID found in '$yaml', skipping\n");
2439             next;
2440         }
2441         my $do = CPAN::Shell->expandany($id);
2442         unless ($do) {
2443             $CPAN::Frontend->mywarn("Could not expand ID '$id', skipping\n");
2444             next;
2445         }
2446         unless ($do->{build_dir}) {
2447             $CPAN::Frontend->mywarn("Distro '$id' has no build_dir, skipping\n");
2448             next;
2449         }
2450         unless ($do->{build_dir} eq $b) {
2451             $CPAN::Frontend->mywarn("Distro '$id' has build_dir '$do->{build_dir}' but expected '$b', skipping\n");
2452             next;
2453         }
2454         push @some, $do;
2455     }
2456
2457     $CPAN::Frontend->mywarn("No tested distributions found.\n"),
2458         return unless @some;
2459
2460     @some = grep { $_->{make_test} && ! $_->{make_test}->failed } @some;
2461     $CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"),
2462         return unless @some;
2463
2464     # @some = grep { not $_->uptodate } @some;
2465     # $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"),
2466     #     return unless @some;
2467
2468     CPAN->debug("some[@some]");
2469     for my $d (@some) {
2470         my $id = $d->can("pretty_id") ? $d->pretty_id : $d->id;
2471         $CPAN::Frontend->myprint("install_tested: Running for $id\n");
2472         $CPAN::Frontend->mysleep(1);
2473         $self->install($d);
2474     }
2475 }
2476
2477 #-> sub CPAN::Shell::upgrade ;
2478 sub upgrade {
2479     my($self,@args) = @_;
2480     $self->install($self->r(@args));
2481 }
2482
2483 #-> sub CPAN::Shell::_u_r_common ;
2484 sub _u_r_common {
2485     my($self) = shift @_;
2486     my($what) = shift @_;
2487     CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
2488     Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
2489           $what && $what =~ /^[aru]$/;
2490     my(@args) = @_;
2491     @args = '/./' unless @args;
2492     my(@result,$module,%seen,%need,$headerdone,
2493        $version_undefs,$version_zeroes,
2494        @version_undefs,@version_zeroes);
2495     $version_undefs = $version_zeroes = 0;
2496     my $sprintf = "%s%-25s%s %9s %9s  %s\n";
2497     my @expand = $self->expand('Module',@args);
2498     my $expand = scalar @expand;
2499     if (0) { # Looks like noise to me, was very useful for debugging
2500              # for metadata cache
2501         $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
2502     }
2503   MODULE: for $module (@expand) {
2504         my $file  = $module->cpan_file;
2505         next MODULE unless defined $file; # ??
2506         $file =~ s!^./../!!;
2507         my($latest) = $module->cpan_version;
2508         my($inst_file) = $module->inst_file;
2509         my($have);
2510         return if $CPAN::Signal;
2511         if ($inst_file) {
2512             if ($what eq "a") {
2513                 $have = $module->inst_version;
2514             } elsif ($what eq "r") {
2515                 $have = $module->inst_version;
2516                 local($^W) = 0;
2517                 if ($have eq "undef") {
2518                     $version_undefs++;
2519                     push @version_undefs, $module->as_glimpse;
2520                 } elsif (CPAN::Version->vcmp($have,0)==0) {
2521                     $version_zeroes++;
2522                     push @version_zeroes, $module->as_glimpse;
2523                 }
2524                 next MODULE unless CPAN::Version->vgt($latest, $have);
2525 # to be pedantic we should probably say:
2526 #    && !($have eq "undef" && $latest ne "undef" && $latest gt "");
2527 # to catch the case where CPAN has a version 0 and we have a version undef
2528             } elsif ($what eq "u") {
2529                 next MODULE;
2530             }
2531         } else {
2532             if ($what eq "a") {
2533                 next MODULE;
2534             } elsif ($what eq "r") {
2535                 next MODULE;
2536             } elsif ($what eq "u") {
2537                 $have = "-";
2538             }
2539         }
2540         return if $CPAN::Signal; # this is sometimes lengthy
2541         $seen{$file} ||= 0;
2542         if ($what eq "a") {
2543             push @result, sprintf "%s %s\n", $module->id, $have;
2544         } elsif ($what eq "r") {
2545             push @result, $module->id;
2546             next MODULE if $seen{$file}++;
2547         } elsif ($what eq "u") {
2548             push @result, $module->id;
2549             next MODULE if $seen{$file}++;
2550             next MODULE if $file =~ /^Contact/;
2551         }
2552         unless ($headerdone++) {
2553             $CPAN::Frontend->myprint("\n");
2554             $CPAN::Frontend->myprint(sprintf(
2555                                              $sprintf,
2556                                              "",
2557                                              "Package namespace",
2558                                              "",
2559                                              "installed",
2560                                              "latest",
2561                                              "in CPAN file"
2562                                             ));
2563         }
2564         my $color_on = "";
2565         my $color_off = "";
2566         if (
2567             $COLOR_REGISTERED
2568             &&
2569             $CPAN::META->has_inst("Term::ANSIColor")
2570             &&
2571             $module->description
2572            ) {
2573             $color_on = Term::ANSIColor::color("green");
2574             $color_off = Term::ANSIColor::color("reset");
2575         }
2576         $CPAN::Frontend->myprint(sprintf $sprintf,
2577                                  $color_on,
2578                                  $module->id,
2579                                  $color_off,
2580                                  $have,
2581                                  $latest,
2582                                  $file);
2583         $need{$module->id}++;
2584     }
2585     unless (%need) {
2586         if ($what eq "u") {
2587             $CPAN::Frontend->myprint("No modules found for @args\n");
2588         } elsif ($what eq "r") {
2589             $CPAN::Frontend->myprint("All modules are up to date for @args\n");
2590         }
2591     }
2592     if ($what eq "r") {
2593         if ($version_zeroes) {
2594             my $s_has = $version_zeroes > 1 ? "s have" : " has";
2595             $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
2596                                      qq{a version number of 0\n});
2597             if ($CPAN::Config->{show_zero_versions}) {
2598                 local $" = "\t";
2599                 $CPAN::Frontend->myprint(qq{  they are\n\t@version_zeroes\n});
2600                 $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 0' }.
2601                                          qq{to hide them)\n});
2602             } else {
2603                 $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 1' }.
2604                                          qq{to show them)\n});
2605             }
2606         }
2607         if ($version_undefs) {
2608             my $s_has = $version_undefs > 1 ? "s have" : " has";
2609             $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
2610                                      qq{parseable version number\n});
2611             if ($CPAN::Config->{show_unparsable_versions}) {
2612                 local $" = "\t";
2613                 $CPAN::Frontend->myprint(qq{  they are\n\t@version_undefs\n});
2614                 $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 0' }.
2615                                          qq{to hide them)\n});
2616             } else {
2617                 $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 1' }.
2618                                          qq{to show them)\n});
2619             }
2620         }
2621     }
2622     @result;
2623 }
2624
2625 #-> sub CPAN::Shell::r ;
2626 sub r {
2627     shift->_u_r_common("r",@_);
2628 }
2629
2630 #-> sub CPAN::Shell::u ;
2631 sub u {
2632     shift->_u_r_common("u",@_);
2633 }
2634
2635 #-> sub CPAN::Shell::failed ;
2636 sub failed {
2637     my($self,$only_id,$silent) = @_;
2638     my @failed;
2639   DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
2640         my $failed = "";
2641       NAY: for my $nosayer ( # order matters!
2642                             "unwrapped",
2643                             "writemakefile",
2644                             "signature_verify",
2645                             "make",
2646                             "make_test",
2647                             "install",
2648                             "make_clean",
2649                            ) {
2650             next unless exists $d->{$nosayer};
2651             next unless defined $d->{$nosayer};
2652             next unless (
2653                          UNIVERSAL::can($d->{$nosayer},"failed") ?
2654                          $d->{$nosayer}->failed :
2655                          $d->{$nosayer} =~ /^NO/
2656                         );
2657             next NAY if $only_id && $only_id != (
2658                                                  UNIVERSAL::can($d->{$nosayer},"commandid")
2659                                                  ?
2660                                                  $d->{$nosayer}->commandid
2661                                                  :
2662                                                  $CPAN::CurrentCommandId
2663                                                 );
2664             $failed = $nosayer;
2665             last;
2666         }
2667         next DIST unless $failed;
2668         my $id = $d->id;
2669         $id =~ s|^./../||;
2670         #$print .= sprintf(
2671         #                  "  %-45s: %s %s\n",
2672         push @failed,
2673             (
2674              UNIVERSAL::can($d->{$failed},"failed") ?
2675              [
2676               $d->{$failed}->commandid,
2677               $id,
2678               $failed,
2679               $d->{$failed}->text,
2680               $d->{$failed}{TIME}||0,
2681              ] :
2682              [
2683               1,
2684               $id,
2685               $failed,
2686               $d->{$failed},
2687               0,
2688              ]
2689             );
2690     }
2691     my $scope;
2692     if ($only_id) {
2693         $scope = "this command";
2694     } elsif ($CPAN::Index::HAVE_REANIMATED) {
2695         $scope = "this or a previous session";
2696         # it might be nice to have a section for previous session and
2697         # a second for this
2698     } else {
2699         $scope = "this session";
2700     }
2701     if (@failed) {
2702         my $print;
2703         my $debug = 0;
2704         if ($debug) {
2705             $print = join "",
2706                 map { sprintf "%5d %-45s: %s %s\n", @$_ }
2707                     sort { $a->[0] <=> $b->[0] } @failed;
2708         } else {
2709             $print = join "",
2710                 map { sprintf " %-45s: %s %s\n", @$_[1..3] }
2711                     sort {
2712                         $a->[0] <=> $b->[0]
2713                             ||
2714                                 $a->[4] <=> $b->[4]
2715                        } @failed;
2716         }
2717         $CPAN::Frontend->myprint("Failed during $scope:\n$print");
2718     } elsif (!$only_id || !$silent) {
2719         $CPAN::Frontend->myprint("Nothing failed in $scope\n");
2720     }
2721 }
2722
2723 # XXX intentionally undocumented because completely bogus, unportable,
2724 # useless, etc.
2725
2726 #-> sub CPAN::Shell::status ;
2727 sub status {
2728     my($self) = @_;
2729     require Devel::Size;
2730     my $ps = FileHandle->new;
2731     open $ps, "/proc/$$/status";
2732     my $vm = 0;
2733     while (<$ps>) {
2734         next unless /VmSize:\s+(\d+)/;
2735         $vm = $1;
2736         last;
2737     }
2738     $CPAN::Frontend->mywarn(sprintf(
2739                                     "%-27s %6d\n%-27s %6d\n",
2740                                     "vm",
2741                                     $vm,
2742                                     "CPAN::META",
2743                                     Devel::Size::total_size($CPAN::META)/1024,
2744                                    ));
2745     for my $k (sort keys %$CPAN::META) {
2746         next unless substr($k,0,4) eq "read";
2747         warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
2748         for my $k2 (sort keys %{$CPAN::META->{$k}}) {
2749             warn sprintf "  %-25s %6d (keys: %6d)\n",
2750                 $k2,
2751                     Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
2752                           scalar keys %{$CPAN::META->{$k}{$k2}};
2753         }
2754     }
2755 }
2756
2757 # compare with install_tested
2758 #-> sub CPAN::Shell::is_tested
2759 sub is_tested {
2760     my($self) = @_;
2761     CPAN::Index->reload;
2762     for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
2763         my $time;
2764         if ($CPAN::META->{is_tested}{$b}) {
2765             $time = scalar(localtime $CPAN::META->{is_tested}{$b});
2766         } else {
2767             $time = scalar localtime;
2768             $time =~ s/\S/?/g;
2769         }
2770         $CPAN::Frontend->myprint(sprintf "%s %s\n", $time, $b);
2771     }
2772 }
2773
2774 #-> sub CPAN::Shell::autobundle ;
2775 sub autobundle {
2776     my($self) = shift;
2777     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
2778     my(@bundle) = $self->_u_r_common("a",@_);
2779     my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
2780     File::Path::mkpath($todir);
2781     unless (-d $todir) {
2782         $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
2783         return;
2784     }
2785     my($y,$m,$d) =  (localtime)[5,4,3];
2786     $y+=1900;
2787     $m++;
2788     my($c) = 0;
2789     my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
2790     my($to) = File::Spec->catfile($todir,"$me.pm");
2791     while (-f $to) {
2792         $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
2793         $to = File::Spec->catfile($todir,"$me.pm");
2794     }
2795     my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
2796     $fh->print(
2797                "package Bundle::$me;\n\n",
2798                "\$VERSION = '0.01';\n\n",
2799                "1;\n\n",
2800                "__END__\n\n",
2801                "=head1 NAME\n\n",
2802                "Bundle::$me - Snapshot of installation on ",
2803                $Config::Config{'myhostname'},
2804                " on ",
2805                scalar(localtime),
2806                "\n\n=head1 SYNOPSIS\n\n",
2807                "perl -MCPAN -e 'install Bundle::$me'\n\n",
2808                "=head1 CONTENTS\n\n",
2809                join("\n", @bundle),
2810                "\n\n=head1 CONFIGURATION\n\n",
2811                Config->myconfig,
2812                "\n\n=head1 AUTHOR\n\n",
2813                "This Bundle has been generated automatically ",
2814                "by the autobundle routine in CPAN.pm.\n",
2815               );
2816     $fh->close;
2817     $CPAN::Frontend->myprint("\nWrote bundle file
2818     $to\n\n");
2819 }
2820
2821 #-> sub CPAN::Shell::expandany ;
2822 sub expandany {
2823     my($self,$s) = @_;
2824     CPAN->debug("s[$s]") if $CPAN::DEBUG;
2825     if ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory
2826         $s = CPAN::Distribution->normalize($s);
2827         return $CPAN::META->instance('CPAN::Distribution',$s);
2828         # Distributions spring into existence, not expand
2829     } elsif ($s =~ m|^Bundle::|) {
2830         $self->local_bundles; # scanning so late for bundles seems
2831                               # both attractive and crumpy: always
2832                               # current state but easy to forget
2833                               # somewhere
2834         return $self->expand('Bundle',$s);
2835     } else {
2836         return $self->expand('Module',$s)
2837             if $CPAN::META->exists('CPAN::Module',$s);
2838     }
2839     return;
2840 }
2841
2842 #-> sub CPAN::Shell::expand ;
2843 sub expand {
2844     my $self = shift;
2845     my($type,@args) = @_;
2846     CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
2847     my $class = "CPAN::$type";
2848     my $methods = ['id'];
2849     for my $meth (qw(name)) {
2850         next unless $class->can($meth);
2851         push @$methods, $meth;
2852     }
2853     $self->expand_by_method($class,$methods,@args);
2854 }
2855
2856 #-> sub CPAN::Shell::expand_by_method ;
2857 sub expand_by_method {
2858     my $self = shift;
2859     my($class,$methods,@args) = @_;
2860     my($arg,@m);
2861     for $arg (@args) {
2862         my($regex,$command);
2863         if ($arg =~ m|^/(.*)/$|) {
2864             $regex = $1;
2865         } elsif ($arg =~ m/=/) {
2866             $command = 1;
2867         }
2868         my $obj;
2869         CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
2870                     $class,
2871                     defined $regex ? $regex : "UNDEFINED",
2872                     defined $command ? $command : "UNDEFINED",
2873                    ) if $CPAN::DEBUG;
2874         if (defined $regex) {
2875             if (CPAN::_sqlite_running) {
2876                 $CPAN::SQLite->search($class, $regex);
2877             }
2878             for $obj (
2879                       $CPAN::META->all_objects($class)
2880                      ) {
2881                 unless ($obj && UNIVERSAL::can($obj,"id") && $obj->id) {
2882                     # BUG, we got an empty object somewhere
2883                     require Data::Dumper;
2884                     CPAN->debug(sprintf(
2885                                         "Bug in CPAN: Empty id on obj[%s][%s]",
2886                                         $obj,
2887                                         Data::Dumper::Dumper($obj)
2888                                        )) if $CPAN::DEBUG;
2889                     next;
2890                 }
2891                 for my $method (@$methods) {
2892                     my $match = eval {$obj->$method() =~ /$regex/i};
2893                     if ($@) {
2894                         my($err) = $@ =~ /^(.+) at .+? line \d+\.$/;
2895                         $err ||= $@; # if we were too restrictive above
2896                         $CPAN::Frontend->mydie("$err\n");
2897                     } elsif ($match) {
2898                         push @m, $obj;
2899                         last;
2900                     }
2901                 }
2902             }
2903         } elsif ($command) {
2904             die "equal sign in command disabled (immature interface), ".
2905                 "you can set
2906  ! \$CPAN::Shell::ADVANCED_QUERY=1
2907 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
2908 that may go away anytime.\n"
2909                     unless $ADVANCED_QUERY;
2910             my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
2911             my($matchcrit) = $criterion =~ m/^~(.+)/;
2912             for my $self (
2913                           sort
2914                           {$a->id cmp $b->id}
2915                           $CPAN::META->all_objects($class)
2916                          ) {
2917                 my $lhs = $self->$method() or next; # () for 5.00503
2918                 if ($matchcrit) {
2919                     push @m, $self if $lhs =~ m/$matchcrit/;
2920                 } else {
2921                     push @m, $self if $lhs eq $criterion;
2922                 }
2923             }
2924         } else {
2925             my($xarg) = $arg;
2926             if ( $class eq 'CPAN::Bundle' ) {
2927                 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
2928             } elsif ($class eq "CPAN::Distribution") {
2929                 $xarg = CPAN::Distribution->normalize($arg);
2930             } else {
2931                 $xarg =~ s/:+/::/g;
2932             }
2933             if ($CPAN::META->exists($class,$xarg)) {
2934                 $obj = $CPAN::META->instance($class,$xarg);
2935             } elsif ($CPAN::META->exists($class,$arg)) {
2936                 $obj = $CPAN::META->instance($class,$arg);
2937             } else {
2938                 next;
2939             }
2940             push @m, $obj;
2941         }
2942     }
2943     @m = sort {$a->id cmp $b->id} @m;
2944     if ( $CPAN::DEBUG ) {
2945         my $wantarray = wantarray;
2946         my $join_m = join ",", map {$_->id} @m;
2947         $self->debug("wantarray[$wantarray]join_m[$join_m]");
2948     }
2949     return wantarray ? @m : $m[0];
2950 }
2951
2952 #-> sub CPAN::Shell::format_result ;
2953 sub format_result {
2954     my($self) = shift;
2955     my($type,@args) = @_;
2956     @args = '/./' unless @args;
2957     my(@result) = $self->expand($type,@args);
2958     my $result = @result == 1 ?
2959         $result[0]->as_string :
2960             @result == 0 ?
2961                 "No objects of type $type found for argument @args\n" :
2962                     join("",
2963                          (map {$_->as_glimpse} @result),
2964                          scalar @result, " items found\n",
2965                         );
2966     $result;
2967 }
2968
2969 #-> sub CPAN::Shell::report_fh ;
2970 {
2971     my $installation_report_fh;
2972     my $previously_noticed = 0;
2973
2974     sub report_fh {
2975         return $installation_report_fh if $installation_report_fh;
2976         if ($CPAN::META->has_inst("File::Temp")) {
2977             $installation_report_fh
2978                 = File::Temp->new(
2979                                   dir      => File::Spec->tmpdir,
2980                                   template => 'cpan_install_XXXX',
2981                                   suffix   => '.txt',
2982                                   unlink   => 0,
2983                                  );
2984         }
2985         unless ( $installation_report_fh ) {
2986             warn("Couldn't open installation report file; " .
2987                  "no report file will be generated."
2988                 ) unless $previously_noticed++;
2989         }
2990     }
2991 }
2992
2993
2994 # The only reason for this method is currently to have a reliable
2995 # debugging utility that reveals which output is going through which
2996 # channel. No, I don't like the colors ;-)
2997
2998 # to turn colordebugging on, write
2999 # cpan> o conf colorize_output 1
3000
3001 #-> sub CPAN::Shell::print_ornamented ;
3002 {
3003     my $print_ornamented_have_warned = 0;
3004     sub colorize_output {
3005         my $colorize_output = $CPAN::Config->{colorize_output};
3006         if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
3007             unless ($print_ornamented_have_warned++) {
3008                 # no myprint/mywarn within myprint/mywarn!
3009                 warn "Colorize_output is set to true but Term::ANSIColor is not
3010 installed. To activate colorized output, please install Term::ANSIColor.\n\n";
3011             }
3012             $colorize_output = 0;
3013         }
3014         return $colorize_output;
3015     }
3016 }
3017
3018
3019 #-> sub CPAN::Shell::print_ornamented ;
3020 sub print_ornamented {
3021     my($self,$what,$ornament) = @_;
3022     return unless defined $what;
3023
3024     local $| = 1; # Flush immediately
3025     if ( $CPAN::Be_Silent ) {
3026         print {report_fh()} $what;
3027         return;
3028     }
3029     my $swhat = "$what"; # stringify if it is an object
3030     if ($CPAN::Config->{term_is_latin}) {
3031         # note: deprecated, need to switch to $LANG and $LC_*
3032         # courtesy jhi:
3033         $swhat
3034             =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
3035     }
3036     if ($self->colorize_output) {
3037         if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
3038             # if you want to have this configurable, please file a bugreport
3039             $ornament = $CPAN::Config->{colorize_debug} || "black on_cyan";
3040         }
3041         my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
3042         if ($@) {
3043             print "Term::ANSIColor rejects color[$ornament]: $@\n
3044 Please choose a different color (Hint: try 'o conf init /color/')\n";
3045         }
3046         # GGOLDBACH/Test-GreaterVersion-0.008 broke wthout this
3047         # $trailer construct. We want the newline be the last thing if
3048         # there is a newline at the end ensuring that the next line is
3049         # empty for other players
3050         my $trailer = "";
3051         $trailer = $1 if $swhat =~ s/([\r\n]+)\z//;
3052         print $color_on,
3053             $swhat,
3054                 Term::ANSIColor::color("reset"),
3055                       $trailer;
3056     } else {
3057         print $swhat;
3058     }
3059 }
3060
3061 #-> sub CPAN::Shell::myprint ;
3062
3063 # where is myprint/mywarn/Frontend/etc. documented? Where to use what?
3064 # I think, we send everything to STDOUT and use print for normal/good
3065 # news and warn for news that need more attention. Yes, this is our
3066 # working contract for now.
3067 sub myprint {
3068     my($self,$what) = @_;
3069     $self->print_ornamented($what,
3070                             $CPAN::Config->{colorize_print}||'bold blue on_white',
3071                            );
3072 }
3073
3074 sub optprint {
3075     my($self,$category,$what) = @_;
3076     my $vname = $category . "_verbosity";
3077     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
3078     if (!$CPAN::Config->{$vname}
3079         || $CPAN::Config->{$vname} =~ /^v/
3080        ) {
3081         $CPAN::Frontend->myprint($what);
3082     }
3083 }
3084
3085 #-> sub CPAN::Shell::myexit ;
3086 sub myexit {
3087     my($self,$what) = @_;
3088     $self->myprint($what);
3089     exit;
3090 }
3091
3092 #-> sub CPAN::Shell::mywarn ;
3093 sub mywarn {
3094     my($self,$what) = @_;
3095     $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
3096 }
3097
3098 # only to be used for shell commands
3099 #-> sub CPAN::Shell::mydie ;
3100 sub mydie {
3101     my($self,$what) = @_;
3102     $self->mywarn($what);
3103
3104     # If it is the shell, we want the following die to be silent,
3105     # but if it is not the shell, we would need a 'die $what'. We need
3106     # to take care that only shell commands use mydie. Is this
3107     # possible?
3108
3109     die "\n";
3110 }
3111
3112 # sub CPAN::Shell::colorable_makemaker_prompt ;
3113 sub colorable_makemaker_prompt {
3114     my($foo,$bar) = @_;
3115     if (CPAN::Shell->colorize_output) {
3116         my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
3117         my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
3118         print $color_on;
3119     }
3120     my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
3121     if (CPAN::Shell->colorize_output) {
3122         print Term::ANSIColor::color('reset');
3123     }
3124     return $ans;
3125 }
3126
3127 # use this only for unrecoverable errors!
3128 #-> sub CPAN::Shell::unrecoverable_error ;
3129 sub unrecoverable_error {
3130     my($self,$what) = @_;
3131     my @lines = split /\n/, $what;
3132     my $longest = 0;
3133     for my $l (@lines) {
3134         $longest = length $l if length $l > $longest;
3135     }
3136     $longest = 62 if $longest > 62;
3137     for my $l (@lines) {
3138         if ($l =~ /^\s*$/) {
3139             $l = "\n";
3140             next;
3141         }
3142         $l = "==> $l";
3143         if (length $l < 66) {
3144             $l = pack "A66 A*", $l, "<==";
3145         }
3146         $l .= "\n";
3147     }
3148     unshift @lines, "\n";
3149     $self->mydie(join "", @lines);
3150 }
3151
3152 #-> sub CPAN::Shell::mysleep ;
3153 sub mysleep {
3154     my($self, $sleep) = @_;
3155     if (CPAN->has_inst("Time::HiRes")) {
3156         Time::HiRes::sleep($sleep);
3157     } else {
3158         sleep($sleep < 1 ? 1 : int($sleep + 0.5));
3159     }
3160 }
3161
3162 #-> sub CPAN::Shell::setup_output ;
3163 sub setup_output {
3164     return if -t STDOUT;
3165     my $odef = select STDERR;
3166     $| = 1;
3167     select STDOUT;
3168     $| = 1;
3169     select $odef;
3170 }
3171
3172 #-> sub CPAN::Shell::rematein ;
3173 # RE-adme||MA-ke||TE-st||IN-stall : nearly everything runs through here
3174 sub rematein {
3175     my $self = shift;
3176     my($meth,@some) = @_;
3177     my @pragma;
3178     while($meth =~ /^(ff?orce|notest)$/) {
3179         push @pragma, $meth;
3180         $meth = shift @some or
3181             $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
3182                                    "cannot continue");
3183     }
3184     setup_output();
3185     CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
3186
3187     # Here is the place to set "test_count" on all involved parties to
3188     # 0. We then can pass this counter on to the involved
3189     # distributions and those can refuse to test if test_count > X. In
3190     # the first stab at it we could use a 1 for "X".
3191
3192     # But when do I reset the distributions to start with 0 again?
3193     # Jost suggested to have a random or cycling interaction ID that
3194     # we pass through. But the ID is something that is just left lying
3195     # around in addition to the counter, so I'd prefer to set the
3196     # counter to 0 now, and repeat at the end of the loop. But what
3197     # about dependencies? They appear later and are not reset, they
3198     # enter the queue but not its copy. How do they get a sensible
3199     # test_count?
3200
3201     # With configure_requires, "get" is vulnerable in recursion.
3202
3203     my $needs_recursion_protection = "get|make|test|install";
3204
3205     # construct the queue
3206     my($s,@s,@qcopy);
3207   STHING: foreach $s (@some) {
3208         my $obj;
3209         if (ref $s) {
3210             CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
3211             $obj = $s;
3212         } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
3213         } elsif ($s =~ m|^/|) { # looks like a regexp
3214             if (substr($s,-1,1) eq ".") {
3215                 $obj = CPAN::Shell->expandany($s);
3216             } else {
3217                 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
3218                                         "not supported.\nRejecting argument '$s'\n");
3219                 $CPAN::Frontend->mysleep(2);
3220                 next;
3221             }
3222         } elsif ($meth eq "ls") {
3223             $self->globls($s,\@pragma);
3224             next STHING;
3225         } else {
3226             CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
3227             $obj = CPAN::Shell->expandany($s);
3228         }
3229         if (0) {
3230         } elsif (ref $obj) {
3231             if ($meth =~ /^($needs_recursion_protection)$/) {
3232                 # it would be silly to check for recursion for look or dump
3233                 # (we are in CPAN::Shell::rematein)
3234                 CPAN->debug("Going to test against recursion") if $CPAN::DEBUG;
3235                 eval {  $obj->color_cmd_tmps(0,1); };
3236                 if ($@) {
3237                     if (ref $@
3238                         and $@->isa("CPAN::Exception::RecursiveDependency")) {
3239                         $CPAN::Frontend->mywarn($@);
3240                     } else {
3241                         if (0) {
3242                             require Carp;
3243                             Carp::confess(sprintf "DEBUG: \$\@[%s]ref[%s]", $@, ref $@);
3244                         }
3245                         die;
3246                     }
3247                 }
3248             }
3249             CPAN::Queue->queue_item(qmod => $obj->id, reqtype => "c");
3250             push @qcopy, $obj;
3251         } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
3252             $obj = $CPAN::META->instance('CPAN::Author',uc($s));
3253             if ($meth =~ /^(dump|ls|reports)$/) {
3254                 $obj->$meth();
3255             } else {
3256                 $CPAN::Frontend->mywarn(
3257                                         join "",
3258                                         "Don't be silly, you can't $meth ",
3259                                         $obj->fullname,
3260                                         " ;-)\n"
3261                                        );
3262                 $CPAN::Frontend->mysleep(2);
3263             }
3264         } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
3265             CPAN::InfoObj->dump($s);
3266         } else {
3267             $CPAN::Frontend
3268                 ->mywarn(qq{Warning: Cannot $meth $s, }.
3269                          qq{don't know what it is.
3270 Try the command
3271
3272     i /$s/
3273
3274 to find objects with matching identifiers.
3275 });
3276             $CPAN::Frontend->mysleep(2);
3277         }
3278     }
3279
3280     # queuerunner (please be warned: when I started to change the
3281     # queue to hold objects instead of names, I made one or two
3282     # mistakes and never found which. I reverted back instead)
3283     while (my $q = CPAN::Queue->first) {
3284         my $obj;
3285         my $s = $q->as_string;
3286         my $reqtype = $q->reqtype || "";
3287         $obj = CPAN::Shell->expandany($s);
3288         unless ($obj) {
3289             # don't know how this can happen, maybe we should panic,
3290             # but maybe we get a solution from the first user who hits
3291             # this unfortunate exception?
3292             $CPAN::Frontend->mywarn("Warning: Could not expand string '$s' ".
3293                                     "to an object. Skipping.\n");
3294             $CPAN::Frontend->mysleep(5);
3295             CPAN::Queue->delete_first($s);
3296             next;
3297         }
3298         $obj->{reqtype} ||= "";
3299         {
3300             # force debugging because CPAN::SQLite somehow delivers us
3301             # an empty object;
3302
3303             # local $CPAN::DEBUG = 1024; # Shell; probably fixed now
3304
3305             CPAN->debug("s[$s]obj-reqtype[$obj->{reqtype}]".
3306                         "q-reqtype[$reqtype]") if $CPAN::DEBUG;
3307         }
3308         if ($obj->{reqtype}) {
3309             if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
3310                 $obj->{reqtype} = $reqtype;
3311                 if (
3312                     exists $obj->{install}
3313                     &&
3314                     (
3315                      UNIVERSAL::can($obj->{install},"failed") ?
3316                      $obj->{install}->failed :
3317                      $obj->{install} =~ /^NO/
3318                     )
3319                    ) {
3320                     delete $obj->{install};
3321                     $CPAN::Frontend->mywarn
3322                         ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
3323                 }
3324             }
3325         } else {
3326             $obj->{reqtype} = $reqtype;
3327         }
3328
3329         for my $pragma (@pragma) {
3330             if ($pragma
3331                 &&
3332                 $obj->can($pragma)) {
3333                 $obj->$pragma($meth);
3334             }
3335         }
3336         if (UNIVERSAL::can($obj, 'called_for')) {
3337             $obj->called_for($s);
3338         }
3339         CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
3340                     qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
3341
3342         push @qcopy, $obj;
3343         if ($meth =~ /^(report)$/) { # they came here with a pragma?
3344             $self->$meth($obj);
3345         } elsif (! UNIVERSAL::can($obj,$meth)) {
3346             # Must never happen
3347             my $serialized = "";
3348             if (0) {
3349             } elsif ($CPAN::META->has_inst("YAML::Syck")) {
3350                 $serialized = YAML::Syck::Dump($obj);
3351             } elsif ($CPAN::META->has_inst("YAML")) {
3352                 $serialized = YAML::Dump($obj);
3353             } elsif ($CPAN::META->has_inst("Data::Dumper")) {
3354                 $serialized = Data::Dumper::Dumper($obj);
3355             } else {
3356                 require overload;
3357                 $serialized = overload::StrVal($obj);
3358             }
3359             CPAN->debug("Going to panic. meth[$meth]s[$s]") if $CPAN::DEBUG;
3360             $CPAN::Frontend->mydie("Panic: obj[$serialized] cannot meth[$meth]");
3361         } elsif ($obj->$meth()) {
3362             CPAN::Queue->delete($s);
3363             CPAN->debug("From queue deleted. meth[$meth]s[$s]") if $CPAN::DEBUG;
3364         } else {
3365             CPAN->debug("Failed. pragma[@pragma]meth[$meth]") if $CPAN::DEBUG;
3366         }
3367
3368         $obj->undelay;
3369         for my $pragma (@pragma) {
3370             my $unpragma = "un$pragma";
3371             if ($obj->can($unpragma)) {
3372                 $obj->$unpragma();
3373             }
3374         }
3375         CPAN::Queue->delete_first($s);
3376     }
3377     if ($meth =~ /^($needs_recursion_protection)$/) {
3378         for my $obj (@qcopy) {
3379             $obj->color_cmd_tmps(0,0);
3380         }
3381     }
3382 }
3383
3384 #-> sub CPAN::Shell::recent ;
3385 sub recent {
3386   my($self) = @_;
3387   if ($CPAN::META->has_inst("XML::LibXML")) {
3388       my $url = $CPAN::Defaultrecent;
3389       $CPAN::Frontend->myprint("Going to fetch '$url'\n");
3390       unless ($CPAN::META->has_usable("LWP")) {
3391           $CPAN::Frontend->mydie("LWP not installed; cannot continue");
3392       }
3393       CPAN::LWP::UserAgent->config;
3394       my $Ua;
3395       eval { $Ua = CPAN::LWP::UserAgent->new; };
3396       if ($@) {
3397           $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
3398       }
3399       my $resp = $Ua->get($url);
3400       unless ($resp->is_success) {
3401           $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
3402       }
3403       $CPAN::Frontend->myprint("DONE\n\n");
3404       my $xml = XML::LibXML->new->parse_string($resp->content);
3405       if (0) {
3406           my $s = $xml->serialize(2);
3407           $s =~ s/\n\s*\n/\n/g;
3408           $CPAN::Frontend->myprint($s);
3409           return;
3410       }
3411       my @distros;
3412       if ($url =~ /winnipeg/) {
3413           my $pubdate = $xml->findvalue("/rss/channel/pubDate");
3414           $CPAN::Frontend->myprint("    pubDate: $pubdate\n\n");
3415           for my $eitem ($xml->findnodes("/rss/channel/item")) {
3416               my $distro = $eitem->findvalue("enclosure/\@url");
3417               $distro =~ s|.*?/authors/id/./../||;
3418               my $size   = $eitem->findvalue("enclosure/\@length");
3419               my $desc   = $eitem->findvalue("description");
3420 \0              $desc =~ s/.+? - //;
3421               $CPAN::Frontend->myprint("$distro [$size b]\n    $desc\n");
3422               push @distros, $distro;
3423           }
3424       } elsif ($url =~ /search.*uploads.rdf/) {
3425           # xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
3426           # xmlns="http://purl.org/rss/1.0/"
3427           # xmlns:taxo="http://purl.org/rss/1.0/modules/taxonomy/"
3428           # xmlns:dc="http://purl.org/dc/elements/1.1/"
3429           # xmlns:syn="http://purl.org/rss/1.0/modules/syndication/"
3430           # xmlns:admin="http://webns.net/mvcb/"
3431
3432
3433           my $dc_date = $xml->findvalue("//*[local-name(.) = 'RDF']/*[local-name(.) = 'channel']/*[local-name(.) = 'date']");
3434           $CPAN::Frontend->myprint("    dc:date: $dc_date\n\n");
3435           my $finish_eitem = 0;
3436           local $SIG{INT} = sub { $finish_eitem = 1 };
3437         EITEM: for my $eitem ($xml->findnodes("//*[local-name(.) = 'RDF']/*[local-name(.) = 'item']")) {
3438               my $distro = $eitem->findvalue("\@rdf:about");
3439               $distro =~ s|.*~||; # remove up to the tilde before the name
3440               $distro =~ s|/$||; # remove trailing slash
3441               $distro =~ s|([^/]+)|\U$1\E|; # upcase the name
3442               my $author = uc $1 or die "distro[$distro] without author, cannot continue";
3443               my $desc   = $eitem->findvalue("*[local-name(.) = 'description']");
3444               my $i = 0;
3445             SUBDIRTEST: while () {
3446                   last SUBDIRTEST if ++$i >= 6; # half a dozen must do!
3447                   if (my @ret = $self->globls("$distro*")) {
3448                       @ret = grep {$_->[2] !~ /meta/} @ret;
3449                       @ret = grep {length $_->[2]} @ret;
3450                       if (@ret) {
3451                           $distro = "$author/$ret[0][2]";
3452                           last SUBDIRTEST;
3453                       }
3454                   }
3455                   $distro =~ s|/|/*/|; # allow it to reside in a subdirectory
3456               }
3457
3458               next EITEM if $distro =~ m|\*|; # did not find the thing
3459               $CPAN::Frontend->myprint("____$desc\n");
3460               push @distros, $distro;
3461               last EITEM if $finish_eitem;
3462           }
3463       }
3464       return \@distros;
3465   } else {
3466       # deprecated old version
3467       $CPAN::Frontend->mydie("no XML::LibXML installed, cannot continue\n");
3468   }
3469 }
3470
3471 #-> sub CPAN::Shell::smoke ;
3472 sub smoke {
3473     my($self) = @_;
3474     my $distros = $self->recent;
3475   DISTRO: for my $distro (@$distros) {
3476         $CPAN::Frontend->myprint(sprintf "Going to download and test '$distro'\n");
3477         {
3478             my $skip = 0;
3479             local $SIG{INT} = sub { $skip = 1 };
3480             for (0..9) {
3481                 $CPAN::Frontend->myprint(sprintf "\r%2d (Hit ^C to skip)", 10-$_);
3482                 sleep 1;
3483                 if ($skip) {
3484                     $CPAN::Frontend->myprint(" skipped\n");
3485                     next DISTRO;
3486                 }
3487             }
3488         }
3489         $CPAN::Frontend->myprint("\r  \n"); # leave the dirty line with a newline
3490         $self->test($distro);
3491     }
3492 }
3493
3494 {
3495     # set up the dispatching methods
3496     no strict "refs";
3497     for my $command (qw(
3498                         clean
3499                         cvs_import
3500                         dump
3501                         force
3502                         fforce
3503                         get
3504                         install
3505                         look
3506                         ls
3507                         make
3508                         notest
3509                         perldoc
3510                         readme
3511                         reports
3512                         test
3513                        )) {
3514         *$command = sub { shift->rematein($command, @_); };
3515     }
3516 }
3517
3518 package CPAN::LWP::UserAgent;
3519 use strict;
3520
3521 sub config {
3522     return if $SETUPDONE;
3523     if ($CPAN::META->has_usable('LWP::UserAgent')) {
3524         require LWP::UserAgent;
3525         @ISA = qw(Exporter LWP::UserAgent);
3526         $SETUPDONE++;
3527     } else {
3528         $CPAN::Frontend->mywarn("  LWP::UserAgent not available\n");
3529     }
3530 }
3531
3532 sub get_basic_credentials {
3533     my($self, $realm, $uri, $proxy) = @_;
3534     if ($USER && $PASSWD) {
3535         return ($USER, $PASSWD);
3536     }
3537     if ( $proxy ) {
3538         ($USER,$PASSWD) = $self->get_proxy_credentials();
3539     } else {
3540         ($USER,$PASSWD) = $self->get_non_proxy_credentials();
3541     }
3542     return($USER,$PASSWD);
3543 }
3544
3545 sub get_proxy_credentials {
3546     my $self = shift;
3547     my ($user, $password);
3548     if ( defined $CPAN::Config->{proxy_user} &&
3549          defined $CPAN::Config->{proxy_pass}) {
3550         $user = $CPAN::Config->{proxy_user};
3551         $password = $CPAN::Config->{proxy_pass};
3552         return ($user, $password);
3553     }
3554     my $username_prompt = "\nProxy authentication needed!
3555  (Note: to permanently configure username and password run
3556    o conf proxy_user your_username
3557    o conf proxy_pass your_password
3558      )\nUsername:";
3559     ($user, $password) =
3560         _get_username_and_password_from_user($username_prompt);
3561     return ($user,$password);
3562 }
3563
3564 sub get_non_proxy_credentials {
3565     my $self = shift;
3566     my ($user,$password);
3567     if ( defined $CPAN::Config->{username} &&
3568          defined $CPAN::Config->{password}) {
3569         $user = $CPAN::Config->{username};
3570         $password = $CPAN::Config->{password};
3571         return ($user, $password);
3572     }
3573     my $username_prompt = "\nAuthentication needed!
3574      (Note: to permanently configure username and password run
3575        o conf username your_username
3576        o conf password your_password
3577      )\nUsername:";
3578
3579     ($user, $password) =
3580         _get_username_and_password_from_user($username_prompt);
3581     return ($user,$password);
3582 }
3583
3584 sub _get_username_and_password_from_user {
3585     my $username_message = shift;
3586     my ($username,$password);
3587
3588     ExtUtils::MakeMaker->import(qw(prompt));
3589     $username = prompt($username_message);
3590         if ($CPAN::META->has_inst("Term::ReadKey")) {
3591             Term::ReadKey::ReadMode("noecho");
3592         }
3593     else {
3594         $CPAN::Frontend->mywarn(
3595             "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"
3596         );
3597     }
3598     $password = prompt("Password:");
3599
3600         if ($CPAN::META->has_inst("Term::ReadKey")) {
3601             Term::ReadKey::ReadMode("restore");
3602         }
3603         $CPAN::Frontend->myprint("\n\n");
3604     return ($username,$password);
3605 }
3606
3607 # mirror(): Its purpose is to deal with proxy authentication. When we
3608 # call SUPER::mirror, we relly call the mirror method in
3609 # LWP::UserAgent. LWP::UserAgent will then call
3610 # $self->get_basic_credentials or some equivalent and this will be
3611 # $self->dispatched to our own get_basic_credentials method.
3612
3613 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3614
3615 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3616 # although we have gone through our get_basic_credentials, the proxy
3617 # server refuses to connect. This could be a case where the username or
3618 # password has changed in the meantime, so I'm trying once again without
3619 # $USER and $PASSWD to give the get_basic_credentials routine another
3620 # chance to set $USER and $PASSWD.
3621
3622 # mirror(): Its purpose is to deal with proxy authentication. When we
3623 # call SUPER::mirror, we relly call the mirror method in
3624 # LWP::UserAgent. LWP::UserAgent will then call
3625 # $self->get_basic_credentials or some equivalent and this will be
3626 # $self->dispatched to our own get_basic_credentials method.
3627
3628 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3629
3630 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3631 # although we have gone through our get_basic_credentials, the proxy
3632 # server refuses to connect. This could be a case where the username or
3633 # password has changed in the meantime, so I'm trying once again without
3634 # $USER and $PASSWD to give the get_basic_credentials routine another
3635 # chance to set $USER and $PASSWD.
3636
3637 sub mirror {
3638     my($self,$url,$aslocal) = @_;
3639     my $result = $self->SUPER::mirror($url,$aslocal);
3640     if ($result->code == 407) {
3641         undef $USER;
3642         undef $PASSWD;
3643         $result = $self->SUPER::mirror($url,$aslocal);
3644     }
3645     $result;
3646 }
3647
3648 package CPAN::FTP;
3649 use strict;
3650
3651 #-> sub CPAN::FTP::ftp_statistics
3652 # if they want to rewrite, they need to pass in a filehandle
3653 sub _ftp_statistics {
3654     my($self,$fh) = @_;
3655     my $locktype = $fh ? LOCK_EX : LOCK_SH;
3656     $fh ||= FileHandle->new;
3657     my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3658     open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!");
3659     my $sleep = 1;
3660     my $waitstart;
3661     while (!CPAN::_flock($fh, $locktype|LOCK_NB)) {
3662         $waitstart ||= localtime();
3663         if ($sleep>3) {
3664             $CPAN::Frontend->mywarn("Waiting for a read lock on '$file' (since $waitstart)\n");
3665         }
3666         $CPAN::Frontend->mysleep($sleep);
3667         if ($sleep <= 3) {
3668             $sleep+=0.33;
3669         } elsif ($sleep <=6) {
3670             $sleep+=0.11;
3671         }
3672     }
3673     my $stats = eval { CPAN->_yaml_loadfile($file); };
3674     if ($@) {
3675         if (ref $@) {
3676             if (ref $@ eq "CPAN::Exception::yaml_not_installed") {
3677                 $CPAN::Frontend->myprint("Warning (usually harmless): $@");
3678                 return;
3679             } elsif (ref $@ eq "CPAN::Exception::yaml_process_error") {
3680                 $CPAN::Frontend->mydie($@);
3681             }
3682         } else {
3683             $CPAN::Frontend->mydie($@);
3684         }
3685     }
3686     return $stats->[0];
3687 }
3688
3689 #-> sub CPAN::FTP::_mytime
3690 sub _mytime () {
3691     if (CPAN->has_inst("Time::HiRes")) {
3692         return Time::HiRes::time();
3693     } else {
3694         return time;
3695     }
3696 }
3697
3698 #-> sub CPAN::FTP::_new_stats
3699 sub _new_stats {
3700     my($self,$file) = @_;
3701     my $ret = {
3702                file => $file,
3703                attempts => [],
3704                start => _mytime,
3705               };
3706     $ret;
3707 }
3708
3709 #-> sub CPAN::FTP::_add_to_statistics
3710 sub _add_to_statistics {
3711     my($self,$stats) = @_;
3712     my $yaml_module = CPAN::_yaml_module;
3713     $self->debug("yaml_module[$yaml_module]") if $CPAN::DEBUG;
3714     if ($CPAN::META->has_inst($yaml_module)) {
3715         $stats->{thesiteurl} = $ThesiteURL;
3716         if (CPAN->has_inst("Time::HiRes")) {
3717             $stats->{end} = Time::HiRes::time();
3718         } else {
3719             $stats->{end} = time;
3720         }
3721         my $fh = FileHandle->new;
3722         my $time = time;
3723         my $sdebug = 0;
3724         my @debug;
3725         @debug = $time if $sdebug;
3726         my $fullstats = $self->_ftp_statistics($fh);
3727         close $fh;
3728         $fullstats->{history} ||= [];
3729         push @debug, scalar @{$fullstats->{history}} if $sdebug;
3730         push @debug, time if $sdebug;
3731         push @{$fullstats->{history}}, $stats;
3732         # arbitrary hardcoded constants until somebody demands to have
3733         # them settable; YAML.pm 0.62 is unacceptably slow with 999;
3734         # YAML::Syck 0.82 has no noticable performance problem with 999;
3735         while (
3736                @{$fullstats->{history}} > 99
3737                || $time - $fullstats->{history}[0]{start} > 14*86400
3738               ) {
3739             shift @{$fullstats->{history}}
3740         }
3741         push @debug, scalar @{$fullstats->{history}} if $sdebug;
3742         push @debug, time if $sdebug;
3743         push @debug, scalar localtime($fullstats->{history}[0]{start}) if $sdebug;
3744         # need no eval because if this fails, it is serious
3745         my $sfile = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3746         CPAN->_yaml_dumpfile("$sfile.$$",$fullstats);
3747         if ( $sdebug ) {
3748             local $CPAN::DEBUG = 512; # FTP
3749             push @debug, time;
3750             CPAN->debug(sprintf("DEBUG history: before_read[%d]before[%d]at[%d]".
3751                                 "after[%d]at[%d]oldest[%s]dumped backat[%d]",
3752                                 @debug,
3753                                ));
3754         }
3755         # Win32 cannot rename a file to an existing filename
3756         unlink($sfile) if ($^O eq 'MSWin32');
3757         rename "$sfile.$$", $sfile
3758             or $CPAN::Frontend->mydie("Could not rename '$sfile.$$' to '$sfile': $!\n");
3759     }
3760 }
3761
3762 # if file is CHECKSUMS, suggest the place where we got the file to be
3763 # checked from, maybe only for young files?
3764 #-> sub CPAN::FTP::_recommend_url_for
3765 sub _recommend_url_for {
3766     my($self, $file) = @_;
3767     my $urllist = $self->_get_urllist;
3768     if ($file =~ s|/CHECKSUMS(.gz)?$||) {
3769         my $fullstats = $self->_ftp_statistics();
3770         my $history = $fullstats->{history} || [];
3771         while (my $last = pop @$history) {
3772             last if $last->{end} - time > 3600; # only young results are interesting
3773             next unless $last->{file}; # dirname of nothing dies!
3774             next unless $file eq File::Basename::dirname($last->{file});
3775             return $last->{thesiteurl};
3776         }
3777     }
3778     if ($CPAN::Config->{randomize_urllist}
3779         &&
3780         rand(1) < $CPAN::Config->{randomize_urllist}
3781        ) {
3782         $urllist->[int rand scalar @$urllist];
3783     } else {
3784         return ();
3785     }
3786 }
3787
3788 #-> sub CPAN::FTP::_get_urllist
3789 sub _get_urllist {
3790     my($self) = @_;
3791     $CPAN::Config->{urllist} ||= [];
3792     unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
3793         $CPAN::Frontend->mywarn("Malformed urllist; ignoring.  Configuration file corrupt?\n");
3794         $CPAN::Config->{urllist} = [];
3795     }
3796     my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}};
3797     for my $u (@urllist) {
3798         CPAN->debug("u[$u]") if $CPAN::DEBUG;
3799         if (UNIVERSAL::can($u,"text")) {
3800             $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
3801         } else {
3802             $u .= "/" unless substr($u,-1) eq "/";
3803             $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
3804         }
3805     }
3806     \@urllist;
3807 }
3808
3809 #-> sub CPAN::FTP::ftp_get ;
3810 sub ftp_get {
3811     my($class,$host,$dir,$file,$target) = @_;
3812     $class->debug(
3813                   qq[Going to fetch file [$file] from dir [$dir]
3814         on host [$host] as local [$target]\n]
3815                  ) if $CPAN::DEBUG;
3816     my $ftp = Net::FTP->new($host);
3817     unless ($ftp) {
3818         $CPAN::Frontend->mywarn("  Could not connect to host '$host' with Net::FTP\n");
3819         return;
3820     }
3821     return 0 unless defined $ftp;
3822     $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
3823     $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
3824     unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ) {
3825         my $msg = $ftp->message;
3826         $CPAN::Frontend->mywarn("  Couldn't login on $host: $msg");
3827         return;
3828     }
3829     unless ( $ftp->cwd($dir) ) {
3830         my $msg = $ftp->message;
3831         $CPAN::Frontend->mywarn("  Couldn't cwd $dir: $msg");
3832         return;
3833     }
3834     $ftp->binary;
3835     $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
3836     unless ( $ftp->get($file,$target) ) {
3837         my $msg = $ftp->message;
3838         $CPAN::Frontend->mywarn("  Couldn't fetch $file from $host: $msg");
3839         return;
3840     }
3841     $ftp->quit; # it's ok if this fails
3842     return 1;
3843 }
3844
3845 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
3846
3847  # > *** /install/perl/live/lib/CPAN.pm-        Wed Sep 24 13:08:48 1997
3848  # > --- /tmp/cp        Wed Sep 24 13:26:40 1997
3849  # > ***************
3850  # > *** 1562,1567 ****
3851  # > --- 1562,1580 ----
3852  # >       return 1 if substr($url,0,4) eq "file";
3853  # >       return 1 unless $url =~ m|://([^/]+)|;
3854  # >       my $host = $1;
3855  # > +     my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
3856  # > +     if ($proxy) {
3857  # > +         $proxy =~ m|://([^/:]+)|;
3858  # > +         $proxy = $1;
3859  # > +         my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
3860  # > +         if ($noproxy) {
3861  # > +             if ($host !~ /$noproxy$/) {
3862  # > +                 $host = $proxy;
3863  # > +             }
3864  # > +         } else {
3865  # > +             $host = $proxy;
3866  # > +         }
3867  # > +     }
3868  # >       require Net::Ping;
3869  # >       return 1 unless $Net::Ping::VERSION >= 2;
3870  # >       my $p;
3871
3872
3873 #-> sub CPAN::FTP::localize ;
3874 sub localize {
3875     my($self,$file,$aslocal,$force) = @_;
3876     $force ||= 0;
3877     Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
3878         unless defined $aslocal;
3879     $self->debug("file[$file] aslocal[$aslocal] force[$force]")
3880         if $CPAN::DEBUG;
3881
3882     if ($^O eq 'MacOS') {
3883         # Comment by AK on 2000-09-03: Uniq short filenames would be
3884         # available in CHECKSUMS file
3885         my($name, $path) = File::Basename::fileparse($aslocal, '');
3886         if (length($name) > 31) {
3887             $name =~ s/(
3888                         \.(
3889                            readme(\.(gz|Z))? |
3890                            (tar\.)?(gz|Z) |
3891                            tgz |
3892                            zip |
3893                            pm\.(gz|Z)
3894                           )
3895                        )$//x;
3896             my $suf = $1;
3897             my $size = 31 - length($suf);
3898             while (length($name) > $size) {
3899                 chop $name;
3900             }
3901             $name .= $suf;
3902             $aslocal = File::Spec->catfile($path, $name);
3903         }
3904     }
3905
3906     if (-f $aslocal && -r _ && !($force & 1)) {
3907         my $size;
3908         if ($size = -s $aslocal) {
3909             $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
3910             return $aslocal;
3911         } else {
3912             # empty file from a previous unsuccessful attempt to download it
3913             unlink $aslocal or
3914                 $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
3915                                        "could not remove.");
3916         }
3917     }
3918     my($maybe_restore) = 0;
3919     if (-f $aslocal) {
3920         rename $aslocal, "$aslocal.bak$$";
3921         $maybe_restore++;
3922     }
3923
3924     my($aslocal_dir) = File::Basename::dirname($aslocal);
3925     $self->mymkpath($aslocal_dir); # too early for file URLs / RT #28438
3926     # Inheritance is not easier to manage than a few if/else branches
3927     if ($CPAN::META->has_usable('LWP::UserAgent')) {
3928         unless ($Ua) {
3929             CPAN::LWP::UserAgent->config;
3930             eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
3931             if ($@) {
3932                 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
3933                     if $CPAN::DEBUG;
3934             } else {
3935                 my($var);
3936                 $Ua->proxy('ftp',  $var)
3937                     if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
3938                 $Ua->proxy('http', $var)
3939                     if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
3940                 $Ua->no_proxy($var)
3941                     if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
3942             }
3943         }
3944     }
3945     for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
3946         $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
3947     }
3948
3949     # Try the list of urls for each single object. We keep a record
3950     # where we did get a file from
3951     my(@reordered,$last);
3952     my $ccurllist = $self->_get_urllist;
3953     $last = $#$ccurllist;
3954     if ($force & 2) { # local cpans probably out of date, don't reorder
3955         @reordered = (0..$last);
3956     } else {
3957         @reordered =
3958             sort {
3959                 (substr($ccurllist->[$b],0,4) eq "file")
3960                     <=>
3961                 (substr($ccurllist->[$a],0,4) eq "file")
3962                     or
3963                 defined($ThesiteURL)
3964                     and
3965                 ($ccurllist->[$b] eq $ThesiteURL)
3966                     <=>
3967                 ($ccurllist->[$a] eq $ThesiteURL)
3968             } 0..$last;
3969     }
3970     my(@levels);
3971     $Themethod ||= "";
3972     $self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG;
3973     my @all_levels = (
3974                       ["dleasy",   "file"],
3975                       ["dleasy"],
3976                       ["dlhard"],
3977                       ["dlhardest"],
3978                       ["dleasy",   "http","defaultsites"],
3979                       ["dlhard",   "http","defaultsites"],
3980                       ["dleasy",   "ftp", "defaultsites"],
3981                       ["dlhard",   "ftp", "defaultsites"],
3982                       ["dlhardest","",    "defaultsites"],
3983                      );
3984     if ($Themethod) {
3985         @levels = grep {$_->[0] eq $Themethod} @all_levels;
3986         push @levels, grep {$_->[0] ne $Themethod} @all_levels;
3987     } else {
3988         @levels = @all_levels;
3989     }
3990     @levels = qw/dleasy/ if $^O eq 'MacOS';
3991     my($levelno);
3992     local $ENV{FTP_PASSIVE} =
3993         exists $CPAN::Config->{ftp_passive} ?
3994         $CPAN::Config->{ftp_passive} : 1;
3995     my $ret;
3996     my $stats = $self->_new_stats($file);
3997   LEVEL: for $levelno (0..$#levels) {
3998         my $level_tuple = $levels[$levelno];
3999         my($level,$scheme,$sitetag) = @$level_tuple;
4000         my $defaultsites = $sitetag && $sitetag eq "defaultsites";
4001         my @urllist;
4002         if ($defaultsites) {
4003             unless (defined $connect_to_internet_ok) {
4004                 $CPAN::Frontend->myprint(sprintf qq{
4005 I would like to connect to one of the following sites to get '%s':
4006
4007 %s
4008 },
4009                                          $file,
4010                                          join("",map { " ".$_->text."\n" } @CPAN::Defaultsites),
4011                                         );
4012                 my $answer = CPAN::Shell::colorable_makemaker_prompt("Is it OK to try to connect to the Internet?", "yes");
4013                 if ($answer =~ /^y/i) {
4014                     $connect_to_internet_ok = 1;
4015                 } else {
4016                     $connect_to_internet_ok = 0;
4017                 }
4018             }
4019             if ($connect_to_internet_ok) {
4020                 @urllist = @CPAN::Defaultsites;
4021             } else {
4022                 @urllist = ();
4023             }
4024         } else {
4025             my @host_seq = $level =~ /dleasy/ ?
4026                 @reordered : 0..$last;  # reordered has file and $Thesiteurl first
4027             @urllist = map { $ccurllist->[$_] } @host_seq;
4028         }
4029         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
4030         my $aslocal_tempfile = $aslocal . ".tmp" . $$;
4031         if (my $recommend = $self->_recommend_url_for($file)) {
4032             @urllist = grep { $_ ne $recommend } @urllist;
4033             unshift @urllist, $recommend;
4034         }
4035         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
4036         $ret = $self->hostdlxxx($level,$scheme,\@urllist,$file,$aslocal_tempfile,$stats);
4037         if ($ret) {
4038             CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG;
4039             if ($ret eq $aslocal_tempfile) {
4040                 # if we got it exactly as we asked for, only then we
4041                 # want to rename
4042                 rename $aslocal_tempfile, $aslocal
4043                     or $CPAN::Frontend->mydie("Error while trying to rename ".
4044                                               "'$ret' to '$aslocal': $!");
4045                 $ret = $aslocal;
4046             }
4047             $Themethod = $level;
4048             my $now = time;
4049             # utime $now, $now, $aslocal; # too bad, if we do that, we
4050                                           # might alter a local mirror
4051             $self->debug("level[$level]") if $CPAN::DEBUG;
4052             last LEVEL;
4053         } else {
4054             unlink $aslocal_tempfile;
4055             last if $CPAN::Signal; # need to cleanup
4056         }
4057     }
4058     if ($ret) {
4059         $stats->{filesize} = -s $ret;
4060     }
4061     $self->debug("before _add_to_statistics") if $CPAN::DEBUG;
4062     $self->_add_to_statistics($stats);
4063     $self->debug("after _add_to_statistics") if $CPAN::DEBUG;
4064     if ($ret) {
4065         unlink "$aslocal.bak$$";
4066         return $ret;
4067     }
4068     unless ($CPAN::Signal) {
4069         my(@mess);
4070         local $" = " ";
4071         if (@{$CPAN::Config->{urllist}}) {
4072             push @mess,
4073                 qq{Please check, if the URLs I found in your configuration file \(}.
4074                     join(", ", @{$CPAN::Config->{urllist}}).
4075                         qq{\) are valid.};
4076         } else {
4077             push @mess, qq{Your urllist is empty!};
4078         }
4079         push @mess, qq{The urllist can be edited.},
4080             qq{E.g. with 'o conf urllist push ftp://myurl/'};
4081         $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
4082         $CPAN::Frontend->mywarn("Could not fetch $file\n");
4083         $CPAN::Frontend->mysleep(2);
4084     }
4085     if ($maybe_restore) {
4086         rename "$aslocal.bak$$", $aslocal;
4087         $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
4088                                  $self->ls($aslocal));
4089         return $aslocal;
4090     }
4091     return;
4092 }
4093
4094 sub mymkpath {
4095     my($self, $aslocal_dir) = @_;
4096     File::Path::mkpath($aslocal_dir);
4097     $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
4098                             qq{directory "$aslocal_dir".
4099     I\'ll continue, but if you encounter problems, they may be due
4100     to insufficient permissions.\n}) unless -w $aslocal_dir;
4101 }
4102
4103 sub hostdlxxx {
4104     my $self = shift;
4105     my $level = shift;
4106     my $scheme = shift;
4107     my $h = shift;
4108     $h = [ grep /^\Q$scheme\E:/, @$h ] if $scheme;
4109     my $method = "host$level";
4110     $self->$method($h, @_);
4111 }
4112
4113 sub _set_attempt {
4114     my($self,$stats,$method,$url) = @_;
4115     push @{$stats->{attempts}}, {
4116                                  method => $method,
4117                                  start => _mytime,
4118                                  url => $url,
4119                                 };
4120 }
4121
4122 # package CPAN::FTP;
4123 sub hostdleasy {
4124     my($self,$host_seq,$file,$aslocal,$stats) = @_;
4125     my($ro_url);
4126   HOSTEASY: for $ro_url (@$host_seq) {
4127         $self->_set_attempt($stats,"dleasy",$ro_url);
4128         my $url .= "$ro_url$file";
4129         $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
4130         if ($url =~ /^file:/) {
4131             my $l;
4132             if ($CPAN::META->has_inst('URI::URL')) {
4133                 my $u =  URI::URL->new($url);
4134                 $l = $u->path;
4135             } else { # works only on Unix, is poorly constructed, but
4136                 # hopefully better than nothing.
4137                 # RFC 1738 says fileurl BNF is
4138                 # fileurl = "file://" [ host | "localhost" ] "/" fpath
4139                 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
4140                 # the code
4141                 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
4142                 $l =~ s|^file:||;                   # assume they
4143                                                     # meant
4144                                                     # file://localhost
4145                 $l =~ s|^/||s
4146                     if ! -f $l && $l =~ m|^/\w:|;   # e.g. /P:
4147             }
4148             $self->debug("local file[$l]") if $CPAN::DEBUG;
4149             if ( -f $l && -r _) {
4150                 $ThesiteURL = $ro_url;
4151                 return $l;
4152             }
4153             if ($l =~ /(.+)\.gz$/) {
4154                 my $ungz = $1;
4155                 if ( -f $ungz && -r _) {
4156                     $ThesiteURL = $ro_url;
4157                     return $ungz;
4158                 }
4159             }
4160             # Maybe mirror has compressed it?
4161             if (-f "$l.gz") {
4162                 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
4163                 eval { CPAN::Tarzip->new("$l.gz")->gunzip($aslocal) };
4164                 if ( -f $aslocal) {
4165                     $ThesiteURL = $ro_url;
4166                     return $aslocal;
4167                 }
4168             }
4169             $CPAN::Frontend->mywarn("Could not find '$l'\n");
4170         }
4171         $self->debug("it was not a file URL") if $CPAN::DEBUG;
4172         if ($CPAN::META->has_usable('LWP')) {
4173             $CPAN::Frontend->myprint("Fetching with LWP:
4174   $url
4175 ");
4176             unless ($Ua) {
4177                 CPAN::LWP::UserAgent->config;
4178                 eval { $Ua = CPAN::LWP::UserAgent->new; };
4179                 if ($@) {
4180                     $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
4181                 }
4182             }
4183             my $res = $Ua->mirror($url, $aslocal);
4184             if ($res->is_success) {
4185                 $ThesiteURL = $ro_url;
4186                 my $now = time;
4187                 utime $now, $now, $aslocal; # download time is more
4188                                             # important than upload
4189                                             # time
4190                 return $aslocal;
4191             } elsif ($url !~ /\.gz(?!\n)\Z/) {
4192                 my $gzurl = "$url.gz";
4193                 $CPAN::Frontend->myprint("Fetching with LWP:
4194   $gzurl
4195 ");
4196                 $res = $Ua->mirror($gzurl, "$aslocal.gz");
4197                 if ($res->is_success) {
4198                     if (eval {CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)}) {
4199                         $ThesiteURL = $ro_url;
4200                         return $aslocal;
4201                     }
4202                 }
4203             } else {
4204                 $CPAN::Frontend->myprint(sprintf(
4205                                                  "LWP failed with code[%s] message[%s]\n",
4206                                                  $res->code,
4207                                                  $res->message,
4208                                                 ));
4209                 # Alan Burlison informed me that in firewall environments
4210                 # Net::FTP can still succeed where LWP fails. So we do not
4211                 # skip Net::FTP anymore when LWP is available.
4212             }
4213         } else {
4214             $CPAN::Frontend->mywarn("  LWP not available\n");
4215         }
4216         return if $CPAN::Signal;
4217         if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
4218             # that's the nice and easy way thanks to Graham
4219             $self->debug("recognized ftp") if $CPAN::DEBUG;
4220             my($host,$dir,$getfile) = ($1,$2,$3);
4221             if ($CPAN::META->has_usable('Net::FTP')) {
4222                 $dir =~ s|/+|/|g;
4223                 $CPAN::Frontend->myprint("Fetching with Net::FTP:
4224   $url
4225 ");
4226                 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
4227                              "aslocal[$aslocal]") if $CPAN::DEBUG;
4228                 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
4229                     $ThesiteURL = $ro_url;
4230                     return $aslocal;
4231                 }
4232                 if ($aslocal !~ /\.gz(?!\n)\Z/) {
4233                     my $gz = "$aslocal.gz";
4234                     $CPAN::Frontend->myprint("Fetching with Net::FTP
4235   $url.gz
4236 ");
4237                     if (CPAN::FTP->ftp_get($host,
4238                                            $dir,
4239                                            "$getfile.gz",
4240                                            $gz) &&
4241                         eval{CPAN::Tarzip->new($gz)->gunzip($aslocal)}
4242                     ) {
4243                         $ThesiteURL = $ro_url;
4244                         return $aslocal;
4245                     }
4246                 }
4247                 # next HOSTEASY;
4248             } else {
4249                 CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG;
4250             }
4251         }
4252         if (
4253             UNIVERSAL::can($ro_url,"text")
4254             and
4255             $ro_url->{FROM} eq "USER"
4256            ) {
4257             ##address #17973: default URLs should not try to override
4258             ##user-defined URLs just because LWP is not available
4259             my $ret = $self->hostdlhard([$ro_url],$file,$aslocal,$stats);
4260             return $ret if $ret;
4261         }
4262         return if $CPAN::Signal;
4263     }
4264 }
4265
4266 # package CPAN::FTP;
4267 sub hostdlhard {
4268     my($self,$host_seq,$file,$aslocal,$stats) = @_;
4269
4270     # Came back if Net::FTP couldn't establish connection (or
4271     # failed otherwise) Maybe they are behind a firewall, but they
4272     # gave us a socksified (or other) ftp program...
4273
4274     my($ro_url);
4275     my($devnull) = $CPAN::Config->{devnull} || "";
4276     # < /dev/null ";
4277     my($aslocal_dir) = File::Basename::dirname($aslocal);
4278     File::Path::mkpath($aslocal_dir);
4279   HOSTHARD: for $ro_url (@$host_seq) {
4280         $self->_set_attempt($stats,"dlhard",$ro_url);
4281         my $url = "$ro_url$file";
4282         my($proto,$host,$dir,$getfile);
4283
4284         # Courtesy Mark Conty mark_conty@cargill.com change from
4285         # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
4286         # to
4287         if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
4288             # proto not yet used
4289             ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
4290         } else {
4291             next HOSTHARD; # who said, we could ftp anything except ftp?
4292         }
4293         next HOSTHARD if $proto eq "file"; # file URLs would have had
4294                                            # success above. Likely a bogus URL
4295
4296         $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
4297
4298         # Try the most capable first and leave ncftp* for last as it only
4299         # does FTP.
4300       DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
4301             my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
4302             next unless defined $funkyftp;
4303             next if $funkyftp =~ /^\s*$/;
4304
4305             my($asl_ungz, $asl_gz);
4306             ($asl_ungz = $aslocal) =~ s/\.gz//;
4307                 $asl_gz = "$asl_ungz.gz";
4308
4309             my($src_switch) = "";
4310             my($chdir) = "";
4311             my($stdout_redir) = " > $asl_ungz";
4312             if ($f eq "lynx") {
4313                 $src_switch = " -source";
4314             } elsif ($f eq "ncftp") {
4315                 $src_switch = " -c";
4316             } elsif ($f eq "wget") {
4317                 $src_switch = " -O $asl_ungz";
4318                 $stdout_redir = "";
4319             } elsif ($f eq 'curl') {
4320                 $src_switch = ' -L -f -s -S --netrc-optional';
4321             }
4322
4323             if ($f eq "ncftpget") {
4324                 $chdir = "cd $aslocal_dir && ";
4325                 $stdout_redir = "";
4326             }
4327             $CPAN::Frontend->myprint(
4328                                      qq[
4329 Trying with "$funkyftp$src_switch" to get
4330     $url
4331 ]);
4332             my($system) =
4333                 "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
4334             $self->debug("system[$system]") if $CPAN::DEBUG;
4335             my($wstatus) = system($system);
4336             if ($f eq "lynx") {
4337                 # lynx returns 0 when it fails somewhere
4338                 if (-s $asl_ungz) {
4339                     my $content = do { local *FH;
4340                                        open FH, $asl_ungz or die;
4341                                        local $/;
4342                                        <FH> };
4343                     if ($content =~ /^<.*(<title>[45]|Error [45])/si) {
4344                         $CPAN::Frontend->mywarn(qq{
4345 No success, the file that lynx has downloaded looks like an error message:
4346 $content
4347 });
4348                         $CPAN::Frontend->mysleep(1);
4349                         next DLPRG;
4350                     }
4351                 } else {
4352                     $CPAN::Frontend->myprint(qq{
4353 No success, the file that lynx has downloaded is an empty file.
4354 });
4355                     next DLPRG;
4356                 }
4357             }
4358             if ($wstatus == 0) {
4359                 if (-s $aslocal) {
4360                     # Looks good
4361                 } elsif ($asl_ungz ne $aslocal) {
4362                     # test gzip integrity
4363                     if (eval{CPAN::Tarzip->new($asl_ungz)->gtest}) {
4364                         # e.g. foo.tar is gzipped --> foo.tar.gz
4365                         rename $asl_ungz, $aslocal;
4366                     } else {
4367                         eval{CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz)};
4368                     }
4369                 }
4370                 $ThesiteURL = $ro_url;
4371                 return $aslocal;
4372             } elsif ($url !~ /\.gz(?!\n)\Z/) {
4373                 unlink $asl_ungz if
4374                     -f $asl_ungz && -s _ == 0;
4375                 my $gz = "$aslocal.gz";
4376                 my $gzurl = "$url.gz";
4377                 $CPAN::Frontend->myprint(
4378                                         qq[
4379     Trying with "$funkyftp$src_switch" to get
4380     $url.gz
4381     ]);
4382                 my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
4383                 $self->debug("system[$system]") if $CPAN::DEBUG;
4384                 my($wstatus);
4385                 if (($wstatus = system($system)) == 0
4386                     &&
4387                     -s $asl_gz
4388                 ) {
4389                     # test gzip integrity
4390                     my $ct = eval{CPAN::Tarzip->new($asl_gz)};
4391                     if ($ct && $ct->gtest) {
4392                         $ct->gunzip($aslocal);
4393                     } else {
4394                         # somebody uncompressed file for us?
4395                         rename $asl_ungz, $aslocal;
4396                     }
4397                     $ThesiteURL = $ro_url;
4398                     return $aslocal;
4399                 } else {
4400                     unlink $asl_gz if -f $asl_gz;
4401                 }
4402             } else {
4403                 my $estatus = $wstatus >> 8;
4404                 my $size = -f $aslocal ?
4405                     ", left\n$aslocal with size ".-s _ :
4406                     "\nWarning: expected file [$aslocal] doesn't exist";
4407                 $CPAN::Frontend->myprint(qq{
4408     System call "$system"
4409     returned status $estatus (wstat $wstatus)$size
4410     });
4411             }
4412             return if $CPAN::Signal;
4413         } # transfer programs
4414     } # host
4415 }
4416
4417 # package CPAN::FTP;
4418 sub hostdlhardest {
4419     my($self,$host_seq,$file,$aslocal,$stats) = @_;
4420
4421     return unless @$host_seq;
4422     my($ro_url);
4423     my($aslocal_dir) = File::Basename::dirname($aslocal);
4424     File::Path::mkpath($aslocal_dir);
4425     my $ftpbin = $CPAN::Config->{ftp};
4426     unless ($ftpbin && length $ftpbin && MM->maybe_command($ftpbin)) {
4427         $CPAN::Frontend->myprint("No external ftp command available\n\n");
4428         return;
4429     }
4430     $CPAN::Frontend->mywarn(qq{
4431 As a last ressort we now switch to the external ftp command '$ftpbin'
4432 to get '$aslocal'.
4433
4434 Doing so often leads to problems that are hard to diagnose.
4435
4436 If you're victim of such problems, please consider unsetting the ftp
4437 config variable with
4438
4439     o conf ftp ""
4440     o conf commit
4441
4442 });
4443     $CPAN::Frontend->mysleep(2);
4444   HOSTHARDEST: for $ro_url (@$host_seq) {
4445         $self->_set_attempt($stats,"dlhardest",$ro_url);
4446         my $url = "$ro_url$file";
4447         $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
4448         unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
4449             next;
4450         }
4451         my($host,$dir,$getfile) = ($1,$2,$3);
4452         my $timestamp = 0;
4453         my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
4454             $ctime,$blksize,$blocks) = stat($aslocal);
4455         $timestamp = $mtime ||= 0;
4456         my($netrc) = CPAN::FTP::netrc->new;
4457         my($netrcfile) = $netrc->netrc;
4458         my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
4459         my $targetfile = File::Basename::basename($aslocal);
4460         my(@dialog);
4461         push(
4462              @dialog,
4463              "lcd $aslocal_dir",
4464              "cd /",
4465              map("cd $_", split /\//, $dir), # RFC 1738
4466              "bin",
4467              "get $getfile $targetfile",
4468              "quit"
4469         );
4470         if (! $netrcfile) {
4471             CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
4472         } elsif ($netrc->hasdefault || $netrc->contains($host)) {
4473             CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
4474                                 $netrc->hasdefault,
4475                                 $netrc->contains($host))) if $CPAN::DEBUG;
4476             if ($netrc->protected) {
4477                 my $dialog = join "", map { "    $_\n" } @dialog;
4478                 my $netrc_explain;
4479                 if ($netrc->contains($host)) {
4480                     $netrc_explain = "Relying that your .netrc entry for '$host' ".
4481                         "manages the login";
4482                 } else {
4483                     $netrc_explain = "Relying that your default .netrc entry ".
4484                         "manages the login";
4485                 }
4486                 $CPAN::Frontend->myprint(qq{
4487   Trying with external ftp to get
4488     $url
4489   $netrc_explain
4490   Going to send the dialog
4491 $dialog
4492 }
4493                 );
4494                 $self->talk_ftp("$ftpbin$verbose $host",
4495                                 @dialog);
4496                 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4497                     $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
4498                 $mtime ||= 0;
4499                 if ($mtime > $timestamp) {
4500                     $CPAN::Frontend->myprint("GOT $aslocal\n");
4501                     $ThesiteURL = $ro_url;
4502                     return $aslocal;
4503                 } else {
4504                     $CPAN::Frontend->myprint("Hmm... Still failed!\n");
4505                 }
4506                     return if $CPAN::Signal;
4507             } else {
4508                 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
4509                                         qq{correctly protected.\n});
4510             }
4511         } else {
4512             $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
4513   nor does it have a default entry\n");
4514         }
4515
4516         # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
4517         # then and login manually to host, using e-mail as
4518         # password.
4519         $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
4520         unshift(
4521                 @dialog,
4522                 "open $host",
4523                 "user anonymous $Config::Config{'cf_email'}"
4524         );
4525         my $dialog = join "", map { "    $_\n" } @dialog;
4526         $CPAN::Frontend->myprint(qq{
4527   Trying with external ftp to get
4528     $url
4529   Going to send the dialog
4530 $dialog
4531 }
4532         );
4533         $self->talk_ftp("$ftpbin$verbose -n", @dialog);
4534         ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4535             $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
4536         $mtime ||= 0;
4537         if ($mtime > $timestamp) {
4538             $CPAN::Frontend->myprint("GOT $aslocal\n");
4539             $ThesiteURL = $ro_url;
4540             return $aslocal;
4541         } else {
4542             $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
4543         }
4544         return if $CPAN::Signal;
4545         $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
4546         $CPAN::Frontend->mysleep(2);
4547     } # host
4548 }
4549
4550 # package CPAN::FTP;
4551 sub talk_ftp {
4552     my($self,$command,@dialog) = @_;
4553     my $fh = FileHandle->new;
4554     $fh->open("|$command") or die "Couldn't open ftp: $!";
4555     foreach (@dialog) { $fh->print("$_\n") }
4556     $fh->close; # Wait for process to complete
4557     my $wstatus = $?;
4558     my $estatus = $wstatus >> 8;
4559     $CPAN::Frontend->myprint(qq{
4560 Subprocess "|$command"
4561   returned status $estatus (wstat $wstatus)
4562 }) if $wstatus;
4563 }
4564
4565 # find2perl needs modularization, too, all the following is stolen
4566 # from there
4567 # CPAN::FTP::ls
4568 sub ls {
4569     my($self,$name) = @_;
4570     my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
4571      $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
4572
4573     my($perms,%user,%group);
4574     my $pname = $name;
4575
4576     if ($blocks) {
4577         $blocks = int(($blocks + 1) / 2);
4578     }
4579     else {
4580         $blocks = int(($sizemm + 1023) / 1024);
4581     }
4582
4583     if    (-f _) { $perms = '-'; }
4584     elsif (-d _) { $perms = 'd'; }
4585     elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
4586     elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
4587     elsif (-p _) { $perms = 'p'; }
4588     elsif (-S _) { $perms = 's'; }
4589     else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
4590
4591     my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
4592     my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
4593     my $tmpmode = $mode;
4594     my $tmp = $rwx[$tmpmode & 7];
4595     $tmpmode >>= 3;
4596     $tmp = $rwx[$tmpmode & 7] . $tmp;
4597     $tmpmode >>= 3;
4598     $tmp = $rwx[$tmpmode & 7] . $tmp;
4599     substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
4600     substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
4601     substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
4602     $perms .= $tmp;
4603
4604     my $user = $user{$uid} || $uid;   # too lazy to implement lookup
4605     my $group = $group{$gid} || $gid;
4606
4607     my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
4608     my($timeyear);
4609     my($moname) = $moname[$mon];
4610     if (-M _ > 365.25 / 2) {
4611         $timeyear = $year + 1900;
4612     }
4613     else {
4614         $timeyear = sprintf("%02d:%02d", $hour, $min);
4615     }
4616
4617     sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
4618              $ino,
4619                   $blocks,
4620                        $perms,
4621                              $nlink,
4622                                  $user,
4623                                       $group,
4624                                            $sizemm,
4625                                                $moname,
4626                                                   $mday,
4627                                                       $timeyear,
4628                                                           $pname;
4629 }
4630
4631 package CPAN::FTP::netrc;
4632 use strict;
4633
4634 # package CPAN::FTP::netrc;
4635 sub new {
4636     my($class) = @_;
4637     my $home = CPAN::HandleConfig::home;
4638     my $file = File::Spec->catfile($home,".netrc");
4639
4640     my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4641        $atime,$mtime,$ctime,$blksize,$blocks)
4642         = stat($file);
4643     $mode ||= 0;
4644     my $protected = 0;
4645
4646     my($fh,@machines,$hasdefault);
4647     $hasdefault = 0;
4648     $fh = FileHandle->new or die "Could not create a filehandle";
4649
4650     if($fh->open($file)) {
4651         $protected = ($mode & 077) == 0;
4652         local($/) = "";
4653       NETRC: while (<$fh>) {
4654             my(@tokens) = split " ", $_;
4655           TOKEN: while (@tokens) {
4656                 my($t) = shift @tokens;
4657                 if ($t eq "default") {
4658                     $hasdefault++;
4659                     last NETRC;
4660                 }
4661                 last TOKEN if $t eq "macdef";
4662                 if ($t eq "machine") {
4663                     push @machines, shift @tokens;
4664                 }
4665             }
4666         }
4667     } else {
4668         $file = $hasdefault = $protected = "";
4669     }
4670
4671     bless {
4672         'mach' => [@machines],
4673         'netrc' => $file,
4674         'hasdefault' => $hasdefault,
4675         'protected' => $protected,
4676     }, $class;
4677 }
4678
4679 # CPAN::FTP::netrc::hasdefault;
4680 sub hasdefault { shift->{'hasdefault'} }
4681 sub netrc      { shift->{'netrc'}      }
4682 sub protected  { shift->{'protected'}  }
4683 sub contains {
4684     my($self,$mach) = @_;
4685     for ( @{$self->{'mach'}} ) {
4686         return 1 if $_ eq $mach;
4687     }
4688     return 0;
4689 }
4690
4691 package CPAN::Complete;
4692 use strict;
4693
4694 sub gnu_cpl {
4695     my($text, $line, $start, $end) = @_;
4696     my(@perlret) = cpl($text, $line, $start);
4697     # find longest common match. Can anybody show me how to peruse
4698     # T::R::Gnu to have this done automatically? Seems expensive.
4699     return () unless @perlret;
4700     my($newtext) = $text;
4701     for (my $i = length($text)+1;;$i++) {
4702         last unless length($perlret[0]) && length($perlret[0]) >= $i;
4703         my $try = substr($perlret[0],0,$i);
4704         my @tries = grep {substr($_,0,$i) eq $try} @perlret;
4705         # warn "try[$try]tries[@tries]";
4706         if (@tries == @perlret) {
4707             $newtext = $try;
4708         } else {
4709             last;
4710         }
4711     }
4712     ($newtext,@perlret);
4713 }
4714
4715 #-> sub CPAN::Complete::cpl ;
4716 sub cpl {
4717     my($word,$line,$pos) = @_;
4718     $word ||= "";
4719     $line ||= "";
4720     $pos ||= 0;
4721     CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4722     $line =~ s/^\s*//;
4723     if ($line =~ s/^((?:notest|f?force)\s*)//) {
4724         $pos -= length($1);
4725     }
4726     my @return;
4727     if ($pos == 0 || $line =~ /^(?:h(?:elp)?|\?)\s/) {
4728         @return = grep /^\Q$word\E/, @CPAN::Complete::COMMANDS;
4729     } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
4730         @return = ();
4731     } elsif ($line =~ /^(a|ls)\s/) {
4732         @return = cplx('CPAN::Author',uc($word));
4733     } elsif ($line =~ /^b\s/) {
4734         CPAN::Shell->local_bundles;
4735         @return = cplx('CPAN::Bundle',$word);
4736     } elsif ($line =~ /^d\s/) {
4737         @return = cplx('CPAN::Distribution',$word);
4738     } elsif ($line =~ m/^(
4739                           [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
4740                          )\s/x ) {
4741         if ($word =~ /^Bundle::/) {
4742             CPAN::Shell->local_bundles;
4743         }
4744         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
4745     } elsif ($line =~ /^i\s/) {
4746         @return = cpl_any($word);
4747     } elsif ($line =~ /^reload\s/) {
4748         @return = cpl_reload($word,$line,$pos);
4749     } elsif ($line =~ /^o\s/) {
4750         @return = cpl_option($word,$line,$pos);
4751     } elsif ($line =~ m/^\S+\s/ ) {
4752         # fallback for future commands and what we have forgotten above
4753         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
4754     } else {
4755         @return = ();
4756     }
4757     return @return;
4758 }
4759
4760 #-> sub CPAN::Complete::cplx ;
4761 sub cplx {
4762     my($class, $word) = @_;
4763     if (CPAN::_sqlite_running) {
4764         $CPAN::SQLite->search($class, "^\Q$word\E");
4765     }
4766     sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
4767 }
4768
4769 #-> sub CPAN::Complete::cpl_any ;
4770 sub cpl_any {
4771     my($word) = shift;
4772     return (
4773             cplx('CPAN::Author',$word),
4774             cplx('CPAN::Bundle',$word),
4775             cplx('CPAN::Distribution',$word),
4776             cplx('CPAN::Module',$word),
4777            );
4778 }
4779
4780 #-> sub CPAN::Complete::cpl_reload ;
4781 sub cpl_reload {
4782     my($word,$line,$pos) = @_;
4783     $word ||= "";
4784     my(@words) = split " ", $line;
4785     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4786     my(@ok) = qw(cpan index);
4787     return @ok if @words == 1;
4788     return grep /^\Q$word\E/, @ok if @words == 2 && $word;
4789 }
4790
4791 #-> sub CPAN::Complete::cpl_option ;
4792 sub cpl_option {
4793     my($word,$line,$pos) = @_;
4794     $word ||= "";
4795     my(@words) = split " ", $line;
4796     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4797     my(@ok) = qw(conf debug);
4798     return @ok if @words == 1;
4799     return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
4800     if (0) {
4801     } elsif ($words[1] eq 'index') {
4802         return ();
4803     } elsif ($words[1] eq 'conf') {
4804         return CPAN::HandleConfig::cpl(@_);
4805     } elsif ($words[1] eq 'debug') {
4806         return sort grep /^\Q$word\E/i,
4807             sort keys %CPAN::DEBUG, 'all';
4808     }
4809 }
4810
4811 package CPAN::Index;
4812 use strict;
4813
4814 #-> sub CPAN::Index::force_reload ;
4815 sub force_reload {
4816     my($class) = @_;
4817     $CPAN::Index::LAST_TIME = 0;
4818     $class->reload(1);
4819 }
4820
4821 #-> sub CPAN::Index::reload ;
4822 sub reload {
4823     my($self,$force) = @_;
4824     my $time = time;
4825
4826     # XXX check if a newer one is available. (We currently read it
4827     # from time to time)
4828     for ($CPAN::Config->{index_expire}) {
4829         $_ = 0.001 unless $_ && $_ > 0.001;
4830     }
4831     unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
4832         # debug here when CPAN doesn't seem to read the Metadata
4833         require Carp;
4834         Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
4835     }
4836     unless ($CPAN::META->{PROTOCOL}) {
4837         $self->read_metadata_cache;
4838         $CPAN::META->{PROTOCOL} ||= "1.0";
4839     }
4840     if ( $CPAN::META->{PROTOCOL} < PROTOCOL  ) {
4841         # warn "Setting last_time to 0";
4842         $LAST_TIME = 0; # No warning necessary
4843     }
4844     if ($LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
4845         and ! $force) {
4846         # called too often
4847         # CPAN->debug("LAST_TIME[$LAST_TIME]index_expire[$CPAN::Config->{index_expire}]time[$time]");
4848     } elsif (0) {
4849         # IFF we are developing, it helps to wipe out the memory
4850         # between reloads, otherwise it is not what a user expects.
4851         undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
4852         $CPAN::META = CPAN->new;
4853     } else {
4854         my($debug,$t2);
4855         local $LAST_TIME = $time;
4856         local $CPAN::META->{PROTOCOL} = PROTOCOL;
4857
4858         my $needshort = $^O eq "dos";
4859
4860         $self->rd_authindex($self
4861                           ->reload_x(
4862                                      "authors/01mailrc.txt.gz",
4863                                      $needshort ?
4864                                      File::Spec->catfile('authors', '01mailrc.gz') :
4865                                      File::Spec->catfile('authors', '01mailrc.txt.gz'),
4866                                      $force));
4867         $t2 = time;
4868         $debug = "timing reading 01[".($t2 - $time)."]";
4869         $time = $t2;
4870         return if $CPAN::Signal; # this is sometimes lengthy
4871         $self->rd_modpacks($self
4872                          ->reload_x(
4873                                     "modules/02packages.details.txt.gz",
4874                                     $needshort ?
4875                                     File::Spec->catfile('modules', '02packag.gz') :
4876                                     File::Spec->catfile('modules', '02packages.details.txt.gz'),
4877                                     $force));
4878         $t2 = time;
4879         $debug .= "02[".($t2 - $time)."]";
4880         $time = $t2;
4881         return if $CPAN::Signal; # this is sometimes lengthy
4882         $self->rd_modlist($self
4883                         ->reload_x(
4884                                    "modules/03modlist.data.gz",
4885                                    $needshort ?
4886                                    File::Spec->catfile('modules', '03mlist.gz') :
4887                                    File::Spec->catfile('modules', '03modlist.data.gz'),
4888                                    $force));
4889         $self->write_metadata_cache;
4890         $t2 = time;
4891         $debug .= "03[".($t2 - $time)."]";
4892         $time = $t2;
4893         CPAN->debug($debug) if $CPAN::DEBUG;
4894     }
4895     if ($CPAN::Config->{build_dir_reuse}) {
4896         $self->reanimate_build_dir;
4897     }
4898     if (CPAN::_sqlite_running) {
4899         $CPAN::SQLite->reload(time => $time, force => $force)
4900             if not $LAST_TIME;
4901     }
4902     $LAST_TIME = $time;
4903     $CPAN::META->{PROTOCOL} = PROTOCOL;
4904 }
4905
4906 #-> sub CPAN::Index::reanimate_build_dir ;
4907 sub reanimate_build_dir {
4908     my($self) = @_;
4909     unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module}||"YAML")) {
4910         return;
4911     }
4912     return if $HAVE_REANIMATED++;
4913     my $d = $CPAN::Config->{build_dir};
4914     my $dh = DirHandle->new;
4915     opendir $dh, $d or return; # does not exist
4916     my $dirent;
4917     my $i = 0;
4918     my $painted = 0;
4919     my $restored = 0;
4920     $CPAN::Frontend->myprint("Going to read $CPAN::Config->{build_dir}/\n");
4921     my @candidates = map { $_->[0] }
4922         sort { $b->[1] <=> $a->[1] }
4923             map { [ $_, -M File::Spec->catfile($d,$_) ] }
4924                 grep {/\.yml$/} readdir $dh;
4925   DISTRO: for $i (0..$#candidates) {
4926         my $dirent = $candidates[$i];
4927         my $y = eval {CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))};
4928         if ($@) {
4929             warn "Error while parsing file '$dirent'; error: '$@'";
4930             next DISTRO;
4931         }
4932         my $c = $y->[0];
4933         if ($c && CPAN->_perl_fingerprint($c->{perl})) {
4934             my $key = $c->{distribution}{ID};
4935             for my $k (keys %{$c->{distribution}}) {
4936                 if ($c->{distribution}{$k}
4937                     && ref $c->{distribution}{$k}
4938                     && UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) {
4939                     $c->{distribution}{$k}{COMMANDID} = $i - @candidates;
4940                 }
4941             }
4942
4943             #we tried to restore only if element already
4944             #exists; but then we do not work with metadata
4945             #turned off.
4946             my $do
4947                 = $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key}
4948                     = $c->{distribution};
4949             for my $skipper (qw(
4950                                 badtestcnt
4951                                 configure_requires_later
4952                                 configure_requires_later_for
4953                                 force_update
4954                                 later
4955                                 later_for
4956                                 notest
4957                                 should_report
4958                                 sponsored_mods
4959                                )) {
4960                 delete $do->{$skipper};
4961             }
4962             # $DB::single = 1;
4963             if ($do->{make_test}
4964                 && $do->{build_dir}
4965                 && !(UNIVERSAL::can($do->{make_test},"failed") ?
4966                      $do->{make_test}->failed :
4967                      $do->{make_test} =~ /^YES/
4968                     )
4969                 && (
4970                     !$do->{install}
4971                     ||
4972                     $do->{install}->failed
4973                    )
4974                ) {
4975                 $CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME});
4976             }
4977             $restored++;
4978         }
4979         $i++;
4980         while (($painted/76) < ($i/@candidates)) {
4981             $CPAN::Frontend->myprint(".");
4982             $painted++;
4983         }
4984     }
4985     $CPAN::Frontend->myprint(sprintf(
4986                                      "DONE\nFound %s old build%s, restored the state of %s\n",
4987                                      @candidates ? sprintf("%d",scalar @candidates) : "no",
4988                                      @candidates==1 ? "" : "s",
4989                                      $restored || "none",
4990                                     ));
4991 }
4992
4993
4994 #-> sub CPAN::Index::reload_x ;
4995 sub reload_x {
4996     my($cl,$wanted,$localname,$force) = @_;
4997     $force |= 2; # means we're dealing with an index here
4998     CPAN::HandleConfig->load; # we should guarantee loading wherever
4999                               # we rely on Config XXX
5000     $localname ||= $wanted;
5001     my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
5002                                          $localname);
5003     if (
5004         -f $abs_wanted &&
5005         -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
5006         !($force & 1)
5007        ) {
5008         my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
5009         $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
5010                    qq{day$s. I\'ll use that.});
5011         return $abs_wanted;
5012     } else {
5013         $force |= 1; # means we're quite serious about it.
5014     }
5015     return CPAN::FTP->localize($wanted,$abs_wanted,$force);
5016 }
5017
5018 #-> sub CPAN::Index::rd_authindex ;
5019 sub rd_authindex {
5020     my($cl, $index_target) = @_;
5021     return unless defined $index_target;
5022     return if CPAN::_sqlite_running;
5023     my @lines;
5024     $CPAN::Frontend->myprint("Going to read $index_target\n");
5025     local(*FH);
5026     tie *FH, 'CPAN::Tarzip', $index_target;
5027     local($/) = "\n";
5028     local($_);
5029     push @lines, split /\012/ while <FH>;
5030     my $i = 0;
5031     my $painted = 0;
5032     foreach (@lines) {
5033         my($userid,$fullname,$email) =
5034             m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/;
5035         $fullname ||= $email;
5036         if ($userid && $fullname && $email) {
5037             my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
5038             $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
5039         } else {
5040             CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG;
5041         }
5042         $i++;
5043         while (($painted/76) < ($i/@lines)) {
5044             $CPAN::Frontend->myprint(".");
5045             $painted++;
5046         }
5047         return if $CPAN::Signal;
5048     }
5049     $CPAN::Frontend->myprint("DONE\n");
5050 }
5051
5052 sub userid {
5053   my($self,$dist) = @_;
5054   $dist = $self->{'id'} unless defined $dist;
5055   my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
5056   $ret;
5057 }
5058
5059 #-> sub CPAN::Index::rd_modpacks ;
5060 sub rd_modpacks {
5061     my($self, $index_target) = @_;
5062     return unless defined $index_target;
5063     return if CPAN::_sqlite_running;
5064     $CPAN::Frontend->myprint("Going to read $index_target\n");
5065     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
5066     local $_;
5067     CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
5068     my $slurp = "";
5069     my $chunk;
5070     while (my $bytes = $fh->READ(\$chunk,8192)) {
5071         $slurp.=$chunk;
5072     }
5073     my @lines = split /\012/, $slurp;
5074     CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
5075     undef $fh;
5076     # read header
5077     my($line_count,$last_updated);
5078     while (@lines) {
5079         my $shift = shift(@lines);
5080         last if $shift =~ /^\s*$/;
5081         $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
5082         $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
5083     }
5084     CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
5085     if (not defined $line_count) {
5086
5087         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
5088 Please check the validity of the index file by comparing it to more
5089 than one CPAN mirror. I'll continue but problems seem likely to
5090 happen.\a
5091 });
5092
5093         $CPAN::Frontend->mysleep(5);
5094     } elsif ($line_count != scalar @lines) {
5095
5096         $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
5097 contains a Line-Count header of %d but I see %d lines there. Please
5098 check the validity of the index file by comparing it to more than one
5099 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
5100 $index_target, $line_count, scalar(@lines));
5101
5102     }
5103     if (not defined $last_updated) {
5104
5105         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
5106 Please check the validity of the index file by comparing it to more
5107 than one CPAN mirror. I'll continue but problems seem likely to
5108 happen.\a
5109 });
5110
5111         $CPAN::Frontend->mysleep(5);
5112     } else {
5113
5114         $CPAN::Frontend
5115             ->myprint(sprintf qq{  Database was generated on %s\n},
5116                       $last_updated);
5117         $DATE_OF_02 = $last_updated;
5118
5119         my $age = time;
5120         if ($CPAN::META->has_inst('HTTP::Date')) {
5121             require HTTP::Date;
5122             $age -= HTTP::Date::str2time($last_updated);
5123         } else {
5124             $CPAN::Frontend->mywarn("  HTTP::Date not available\n");
5125             require Time::Local;
5126             my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
5127             $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
5128             $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
5129         }
5130         $age /= 3600*24;
5131         if ($age > 30) {
5132
5133             $CPAN::Frontend
5134                 ->mywarn(sprintf
5135                          qq{Warning: This index file is %d days old.
5136   Please check the host you chose as your CPAN mirror for staleness.
5137   I'll continue but problems seem likely to happen.\a\n},
5138                          $age);
5139
5140         } elsif ($age < -1) {
5141
5142             $CPAN::Frontend
5143                 ->mywarn(sprintf
5144                          qq{Warning: Your system date is %d days behind this index file!
5145   System time:          %s
5146   Timestamp index file: %s
5147   Please fix your system time, problems with the make command expected.\n},
5148                          -$age,
5149                          scalar gmtime,
5150                          $DATE_OF_02,
5151                         );
5152
5153         }
5154     }
5155
5156
5157     # A necessity since we have metadata_cache: delete what isn't
5158     # there anymore
5159     my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
5160     CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
5161     my(%exists);
5162     my $i = 0;
5163     my $painted = 0;
5164     foreach (@lines) {
5165         # before 1.56 we split into 3 and discarded the rest. From
5166         # 1.57 we assign remaining text to $comment thus allowing to
5167         # influence isa_perl
5168         my($mod,$version,$dist,$comment) = split " ", $_, 4;
5169         my($bundle,$id,$userid);
5170
5171         if ($mod eq 'CPAN' &&
5172             ! (
5173             CPAN::Queue->exists('Bundle::CPAN') ||
5174             CPAN::Queue->exists('CPAN')
5175             )
5176         ) {
5177             local($^W)= 0;
5178             if ($version > $CPAN::VERSION) {
5179                 $CPAN::Frontend->mywarn(qq{
5180   New CPAN.pm version (v$version) available.
5181   [Currently running version is v$CPAN::VERSION]
5182   You might want to try
5183     install CPAN
5184     reload cpan
5185   to both upgrade CPAN.pm and run the new version without leaving
5186   the current session.
5187
5188 }); #});
5189                 $CPAN::Frontend->mysleep(2);
5190                 $CPAN::Frontend->myprint(qq{\n});
5191             }
5192             last if $CPAN::Signal;
5193         } elsif ($mod =~ /^Bundle::(.*)/) {
5194             $bundle = $1;
5195         }
5196
5197         if ($bundle) {
5198             $id =  $CPAN::META->instance('CPAN::Bundle',$mod);
5199             # Let's make it a module too, because bundles have so much
5200             # in common with modules.
5201
5202             # Changed in 1.57_63: seems like memory bloat now without
5203             # any value, so commented out
5204
5205             # $CPAN::META->instance('CPAN::Module',$mod);
5206
5207         } else {
5208
5209             # instantiate a module object
5210             $id = $CPAN::META->instance('CPAN::Module',$mod);
5211
5212         }
5213
5214         # Although CPAN prohibits same name with different version the
5215         # indexer may have changed the version for the same distro
5216         # since the last time ("Force Reindexing" feature)
5217         if ($id->cpan_file ne $dist
5218             ||
5219             $id->cpan_version ne $version
5220            ) {
5221             $userid = $id->userid || $self->userid($dist);
5222             $id->set(
5223                      'CPAN_USERID' => $userid,
5224                      'CPAN_VERSION' => $version,
5225                      'CPAN_FILE' => $dist,
5226                     );
5227         }
5228
5229         # instantiate a distribution object
5230         if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
5231         # we do not need CONTAINSMODS unless we do something with
5232         # this dist, so we better produce it on demand.
5233
5234         ## my $obj = $CPAN::META->instance(
5235         ##                                 'CPAN::Distribution' => $dist
5236         ##                                );
5237         ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
5238         } else {
5239             $CPAN::META->instance(
5240                                   'CPAN::Distribution' => $dist
5241                                  )->set(
5242                                         'CPAN_USERID' => $userid,
5243                                         'CPAN_COMMENT' => $comment,
5244                                        );
5245         }
5246         if ($secondtime) {
5247             for my $name ($mod,$dist) {
5248                 # $self->debug("exists name[$name]") if $CPAN::DEBUG;
5249                 $exists{$name} = undef;
5250             }
5251         }
5252         $i++;
5253         while (($painted/76) < ($i/@lines)) {
5254             $CPAN::Frontend->myprint(".");
5255             $painted++;
5256         }
5257         return if $CPAN::Signal;
5258     }
5259     $CPAN::Frontend->myprint("DONE\n");
5260     if ($secondtime) {
5261         for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
5262             for my $o ($CPAN::META->all_objects($class)) {
5263                 next if exists $exists{$o->{ID}};
5264                 $CPAN::META->delete($class,$o->{ID});
5265                 # CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
5266                 #     if $CPAN::DEBUG;
5267             }
5268         }
5269     }
5270 }
5271
5272 #-> sub CPAN::Index::rd_modlist ;
5273 sub rd_modlist {
5274     my($cl,$index_target) = @_;
5275     return unless defined $index_target;
5276     return if CPAN::_sqlite_running;
5277     $CPAN::Frontend->myprint("Going to read $index_target\n");
5278     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
5279     local $_;
5280     my $slurp = "";
5281     my $chunk;
5282     while (my $bytes = $fh->READ(\$chunk,8192)) {
5283         $slurp.=$chunk;
5284     }
5285     my @eval2 = split /\012/, $slurp;
5286
5287     while (@eval2) {
5288         my $shift = shift(@eval2);
5289         if ($shift =~ /^Date:\s+(.*)/) {
5290             if ($DATE_OF_03 eq $1) {
5291                 $CPAN::Frontend->myprint("Unchanged.\n");
5292                 return;
5293             }
5294             ($DATE_OF_03) = $1;
5295         }
5296         last if $shift =~ /^\s*$/;
5297     }
5298     push @eval2, q{CPAN::Modulelist->data;};
5299     local($^W) = 0;
5300     my($comp) = Safe->new("CPAN::Safe1");
5301     my($eval2) = join("\n", @eval2);
5302     CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG;
5303     my $ret = $comp->reval($eval2);
5304     Carp::confess($@) if $@;
5305     return if $CPAN::Signal;
5306     my $i = 0;
5307     my $until = keys(%$ret);
5308     my $painted = 0;
5309     CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
5310     for (keys %$ret) {
5311         my $obj = $CPAN::META->instance("CPAN::Module",$_);
5312         delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
5313         $obj->set(%{$ret->{$_}});
5314         $i++;
5315         while (($painted/76) < ($i/$until)) {
5316             $CPAN::Frontend->myprint(".");
5317             $painted++;
5318         }
5319         return if $CPAN::Signal;
5320     }
5321     $CPAN::Frontend->myprint("DONE\n");
5322 }
5323
5324 #-> sub CPAN::Index::write_metadata_cache ;
5325 sub write_metadata_cache {
5326     my($self) = @_;
5327     return unless $CPAN::Config->{'cache_metadata'};
5328     return if CPAN::_sqlite_running;
5329     return unless $CPAN::META->has_usable("Storable");
5330     my $cache;
5331     foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
5332                       CPAN::Distribution)) {
5333         $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
5334     }
5335     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
5336     $cache->{last_time} = $LAST_TIME;
5337     $cache->{DATE_OF_02} = $DATE_OF_02;
5338     $cache->{PROTOCOL} = PROTOCOL;
5339     $CPAN::Frontend->myprint("Going to write $metadata_file\n");
5340     eval { Storable::nstore($cache, $metadata_file) };
5341     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
5342 }
5343
5344 #-> sub CPAN::Index::read_metadata_cache ;
5345 sub read_metadata_cache {
5346     my($self) = @_;
5347     return unless $CPAN::Config->{'cache_metadata'};
5348     return if CPAN::_sqlite_running;
5349     return unless $CPAN::META->has_usable("Storable");
5350     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
5351     return unless -r $metadata_file and -f $metadata_file;
5352     $CPAN::Frontend->myprint("Going to read $metadata_file\n");
5353     my $cache;
5354     eval { $cache = Storable::retrieve($metadata_file) };
5355     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
5356     if (!$cache || !UNIVERSAL::isa($cache, 'HASH')) {
5357         $LAST_TIME = 0;
5358         return;
5359     }
5360     if (exists $cache->{PROTOCOL}) {
5361         if (PROTOCOL > $cache->{PROTOCOL}) {
5362             $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
5363                                             "with protocol v%s, requiring v%s\n",
5364                                             $cache->{PROTOCOL},
5365                                             PROTOCOL)
5366                                    );
5367             return;
5368         }
5369     } else {
5370         $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
5371                                 "with protocol v1.0\n");
5372         return;
5373     }
5374     my $clcnt = 0;
5375     my $idcnt = 0;
5376     while(my($class,$v) = each %$cache) {
5377         next unless $class =~ /^CPAN::/;
5378         $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
5379         while (my($id,$ro) = each %$v) {
5380             $CPAN::META->{readwrite}{$class}{$id} ||=
5381                 $class->new(ID=>$id, RO=>$ro);
5382             $idcnt++;
5383         }
5384         $clcnt++;
5385     }
5386     unless ($clcnt) { # sanity check
5387         $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
5388         return;
5389     }
5390     if ($idcnt < 1000) {
5391         $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
5392                                  "in $metadata_file\n");
5393         return;
5394     }
5395     $CPAN::META->{PROTOCOL} ||=
5396         $cache->{PROTOCOL}; # reading does not up or downgrade, but it
5397                             # does initialize to some protocol
5398     $LAST_TIME = $cache->{last_time};
5399     $DATE_OF_02 = $cache->{DATE_OF_02};
5400     $CPAN::Frontend->myprint("  Database was generated on $DATE_OF_02\n")
5401         if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
5402     return;
5403 }
5404
5405 package CPAN::InfoObj;
5406 use strict;
5407
5408 sub ro {
5409     my $self = shift;
5410     exists $self->{RO} and return $self->{RO};
5411 }
5412
5413 #-> sub CPAN::InfoObj::cpan_userid
5414 sub cpan_userid {
5415     my $self = shift;
5416     my $ro = $self->ro;
5417     if ($ro) {
5418         return $ro->{CPAN_USERID} || "N/A";
5419     } else {
5420         $self->debug("ID[$self->{ID}]");
5421         # N/A for bundles found locally
5422         return "N/A";
5423     }
5424 }
5425
5426 sub id { shift->{ID}; }
5427
5428 #-> sub CPAN::InfoObj::new ;
5429 sub new {
5430     my $this = bless {}, shift;
5431     %$this = @_;
5432     $this
5433 }
5434
5435 # The set method may only be used by code that reads index data or
5436 # otherwise "objective" data from the outside world. All session
5437 # related material may do anything else with instance variables but
5438 # must not touch the hash under the RO attribute. The reason is that
5439 # the RO hash gets written to Metadata file and is thus persistent.
5440
5441 #-> sub CPAN::InfoObj::safe_chdir ;
5442 sub safe_chdir {
5443   my($self,$todir) = @_;
5444   # we die if we cannot chdir and we are debuggable
5445   Carp::confess("safe_chdir called without todir argument")
5446         unless defined $todir and length $todir;
5447   if (chdir $todir) {
5448     $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
5449         if $CPAN::DEBUG;
5450   } else {
5451     if (-e $todir) {
5452         unless (-x $todir) {
5453             unless (chmod 0755, $todir) {
5454                 my $cwd = CPAN::anycwd();
5455                 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
5456                                         "permission to change the permission; cannot ".
5457                                         "chdir to '$todir'\n");
5458                 $CPAN::Frontend->mysleep(5);
5459                 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
5460                                        qq{to todir[$todir]: $!});
5461             }
5462         }
5463     } else {
5464         $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n");
5465     }
5466     if (chdir $todir) {
5467       $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
5468           if $CPAN::DEBUG;
5469     } else {
5470       my $cwd = CPAN::anycwd();
5471       $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
5472                              qq{to todir[$todir] (a chmod has been issued): $!});
5473     }
5474   }
5475 }
5476
5477 #-> sub CPAN::InfoObj::set ;
5478 sub set {
5479     my($self,%att) = @_;
5480     my $class = ref $self;
5481
5482     # This must be ||=, not ||, because only if we write an empty
5483     # reference, only then the set method will write into the readonly
5484     # area. But for Distributions that spring into existence, maybe
5485     # because of a typo, we do not like it that they are written into
5486     # the readonly area and made permanent (at least for a while) and
5487     # that is why we do not "allow" other places to call ->set.
5488     unless ($self->id) {
5489         CPAN->debug("Bug? Empty ID, rejecting");
5490         return;
5491     }
5492     my $ro = $self->{RO} =
5493         $CPAN::META->{readonly}{$class}{$self->id} ||= {};
5494
5495     while (my($k,$v) = each %att) {
5496         $ro->{$k} = $v;
5497     }
5498 }
5499
5500 #-> sub CPAN::InfoObj::as_glimpse ;
5501 sub as_glimpse {
5502     my($self) = @_;
5503     my(@m);
5504     my $class = ref($self);
5505     $class =~ s/^CPAN:://;
5506     my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID};
5507     push @m, sprintf "%-15s %s\n", $class, $id;
5508     join "", @m;
5509 }
5510
5511 #-> sub CPAN::InfoObj::as_string ;
5512 sub as_string {
5513     my($self) = @_;
5514     my(@m);
5515     my $class = ref($self);
5516     $class =~ s/^CPAN:://;
5517     push @m, $class, " id = $self->{ID}\n";
5518     my $ro;
5519     unless ($ro = $self->ro) {
5520         if (substr($self->{ID},-1,1) eq ".") { # directory
5521             $ro = +{};
5522         } else {
5523             $CPAN::Frontend->mywarn("Unknown object $self->{ID}\n");
5524             $CPAN::Frontend->mysleep(5);
5525             return;
5526         }
5527     }
5528     for (sort keys %$ro) {
5529         # next if m/^(ID|RO)$/;
5530         my $extra = "";
5531         if ($_ eq "CPAN_USERID") {
5532             $extra .= " (";
5533             $extra .= $self->fullname;
5534             my $email; # old perls!
5535             if ($email = $CPAN::META->instance("CPAN::Author",
5536                                                $self->cpan_userid
5537                                               )->email) {
5538                 $extra .= " <$email>";
5539             } else {
5540                 $extra .= " <no email>";
5541             }
5542             $extra .= ")";
5543         } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
5544             push @m, sprintf "    %-12s %s\n", $_, $self->fullname;
5545             next;
5546         }
5547         next unless defined $ro->{$_};
5548         push @m, sprintf "    %-12s %s%s\n", $_, $ro->{$_}, $extra;
5549     }
5550   KEY: for (sort keys %$self) {
5551         next if m/^(ID|RO)$/;
5552         unless (defined $self->{$_}) {
5553             delete $self->{$_};
5554             next KEY;
5555         }
5556         if (ref($self->{$_}) eq "ARRAY") {
5557             push @m, sprintf "    %-12s %s\n", $_, "@{$self->{$_}}";
5558         } elsif (ref($self->{$_}) eq "HASH") {
5559             my $value;
5560             if (/^CONTAINSMODS$/) {
5561                 $value = join(" ",sort keys %{$self->{$_}});
5562             } elsif (/^prereq_pm$/) {
5563                 my @value;
5564                 my $v = $self->{$_};
5565                 for my $x (sort keys %$v) {
5566                     my @svalue;
5567                     for my $y (sort keys %{$v->{$x}}) {
5568                         push @svalue, "$y=>$v->{$x}{$y}";
5569                     }
5570                     push @value, "$x\:" . join ",", @svalue if @svalue;
5571                 }
5572                 $value = join ";", @value;
5573             } else {
5574                 $value = $self->{$_};
5575             }
5576             push @m, sprintf(
5577                              "    %-12s %s\n",
5578                              $_,
5579                              $value,
5580                             );
5581         } else {
5582             push @m, sprintf "    %-12s %s\n", $_, $self->{$_};
5583         }
5584     }
5585     join "", @m, "\n";
5586 }
5587
5588 #-> sub CPAN::InfoObj::fullname ;
5589 sub fullname {
5590     my($self) = @_;
5591     $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
5592 }
5593
5594 #-> sub CPAN::InfoObj::dump ;
5595 sub dump {
5596     my($self, $what) = @_;
5597     unless ($CPAN::META->has_inst("Data::Dumper")) {
5598         $CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
5599     }
5600     local $Data::Dumper::Sortkeys;
5601     $Data::Dumper::Sortkeys = 1;
5602     my $out = Data::Dumper::Dumper($what ? eval $what : $self);
5603     if (length $out > 100000) {
5604         my $fh_pager = FileHandle->new;
5605         local($SIG{PIPE}) = "IGNORE";
5606         my $pager = $CPAN::Config->{'pager'} || "cat";
5607         $fh_pager->open("|$pager")
5608             or die "Could not open pager $pager\: $!";
5609         $fh_pager->print($out);
5610         close $fh_pager;
5611     } else {
5612         $CPAN::Frontend->myprint($out);
5613     }
5614 }
5615
5616 package CPAN::Author;
5617 use strict;
5618
5619 #-> sub CPAN::Author::force
5620 sub force {
5621     my $self = shift;
5622     $self->{force}++;
5623 }
5624
5625 #-> sub CPAN::Author::force
5626 sub unforce {
5627     my $self = shift;
5628     delete $self->{force};
5629 }
5630
5631 #-> sub CPAN::Author::id
5632 sub id {
5633     my $self = shift;
5634     my $id = $self->{ID};
5635     $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
5636     $id;
5637 }
5638
5639 #-> sub CPAN::Author::as_glimpse ;
5640 sub as_glimpse {
5641     my($self) = @_;
5642     my(@m);
5643     my $class = ref($self);
5644     $class =~ s/^CPAN:://;
5645     push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
5646                      $class,
5647                      $self->{ID},
5648                      $self->fullname,
5649                      $self->email);
5650     join "", @m;
5651 }
5652
5653 #-> sub CPAN::Author::fullname ;
5654 sub fullname {
5655     shift->ro->{FULLNAME};
5656 }
5657 *name = \&fullname;
5658
5659 #-> sub CPAN::Author::email ;
5660 sub email    { shift->ro->{EMAIL}; }
5661
5662 #-> sub CPAN::Author::ls ;
5663 sub ls {
5664     my $self = shift;
5665     my $glob = shift || "";
5666     my $silent = shift || 0;
5667     my $id = $self->id;
5668
5669     # adapted from CPAN::Distribution::verifyCHECKSUM ;
5670     my(@csf); # chksumfile
5671     @csf = $self->id =~ /(.)(.)(.*)/;
5672     $csf[1] = join "", @csf[0,1];
5673     $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
5674     my(@dl);
5675     @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
5676     unless (grep {$_->[2] eq $csf[1]} @dl) {
5677         $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
5678         return;
5679     }
5680     @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
5681     unless (grep {$_->[2] eq $csf[2]} @dl) {
5682         $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
5683         return;
5684     }
5685     @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
5686     if ($glob) {
5687         if ($CPAN::META->has_inst("Text::Glob")) {
5688             my $rglob = Text::Glob::glob_to_regex($glob);
5689             @dl = grep { $_->[2] =~ /$rglob/ } @dl;
5690         } else {
5691             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
5692         }
5693     }
5694     unless ($silent >= 2) {
5695         $CPAN::Frontend->myprint(join "", map {
5696             sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
5697         } sort { $a->[2] cmp $b->[2] } @dl);
5698     }
5699     @dl;
5700 }
5701
5702 # returns an array of arrays, the latter contain (size,mtime,filename)
5703 #-> sub CPAN::Author::dir_listing ;
5704 sub dir_listing {
5705     my $self = shift;
5706     my $chksumfile = shift;
5707     my $recursive = shift;
5708     my $may_ftp = shift;
5709
5710     my $lc_want =
5711         File::Spec->catfile($CPAN::Config->{keep_source_where},
5712                             "authors", "id", @$chksumfile);
5713
5714     my $fh;
5715
5716     # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
5717     # hazard.  (Without GPG installed they are not that much better,
5718     # though.)
5719     $fh = FileHandle->new;
5720     if (open($fh, $lc_want)) {
5721         my $line = <$fh>; close $fh;
5722         unlink($lc_want) unless $line =~ /PGP/;
5723     }
5724
5725     local($") = "/";
5726     # connect "force" argument with "index_expire".
5727     my $force = $self->{force};
5728     if (my @stat = stat $lc_want) {
5729         $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
5730     }
5731     my $lc_file;
5732     if ($may_ftp) {
5733         $lc_file = CPAN::FTP->localize(
5734                                        "authors/id/@$chksumfile",
5735                                        $lc_want,
5736                                        $force,
5737                                       );
5738         unless ($lc_file) {
5739             $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
5740             $chksumfile->[-1] .= ".gz";
5741             $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
5742                                            "$lc_want.gz",1);
5743             if ($lc_file) {
5744                 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
5745                 eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
5746             } else {
5747                 return;
5748             }
5749         }
5750     } else {
5751         $lc_file = $lc_want;
5752         # we *could* second-guess and if the user has a file: URL,
5753         # then we could look there. But on the other hand, if they do
5754         # have a file: URL, wy did they choose to set
5755         # $CPAN::Config->{show_upload_date} to false?
5756     }
5757
5758     # adapted from CPAN::Distribution::CHECKSUM_check_file ;
5759     $fh = FileHandle->new;
5760     my($cksum);
5761     if (open $fh, $lc_file) {
5762         local($/);
5763         my $eval = <$fh>;
5764         $eval =~ s/\015?\012/\n/g;
5765         close $fh;
5766         my($comp) = Safe->new();
5767         $cksum = $comp->reval($eval);
5768         if ($@) {
5769             rename $lc_file, "$lc_file.bad";
5770             Carp::confess($@) if $@;
5771         }
5772     } elsif ($may_ftp) {
5773         Carp::carp "Could not open '$lc_file' for reading.";
5774     } else {
5775         # Maybe should warn: "You may want to set show_upload_date to a true value"
5776         return;
5777     }
5778     my(@result,$f);
5779     for $f (sort keys %$cksum) {
5780         if (exists $cksum->{$f}{isdir}) {
5781             if ($recursive) {
5782                 my(@dir) = @$chksumfile;
5783                 pop @dir;
5784                 push @dir, $f, "CHECKSUMS";
5785                 push @result, map {
5786                     [$_->[0], $_->[1], "$f/$_->[2]"]
5787                 } $self->dir_listing(\@dir,1,$may_ftp);
5788             } else {
5789                 push @result, [ 0, "-", $f ];
5790             }
5791         } else {
5792             push @result, [
5793                            ($cksum->{$f}{"size"}||0),
5794                            $cksum->{$f}{"mtime"}||"---",
5795                            $f
5796                           ];
5797         }
5798     }
5799     @result;
5800 }
5801
5802 #-> sub CPAN::Author::reports
5803 sub reports {
5804     $CPAN::Frontend->mywarn("reports on authors not implemented.
5805 Please file a bugreport if you need this.\n");
5806 }
5807
5808 package CPAN::Distribution;
5809 use strict;
5810
5811 # Accessors
5812 sub cpan_comment {
5813     my $self = shift;
5814     my $ro = $self->ro or return;
5815     $ro->{CPAN_COMMENT}
5816 }
5817
5818 #-> CPAN::Distribution::undelay
5819 sub undelay {
5820     my $self = shift;
5821     for my $delayer (
5822                      "configure_requires_later",
5823                      "configure_requires_later_for",
5824                      "later",
5825                      "later_for",
5826                     ) {
5827         delete $self->{$delayer};
5828     }
5829 }
5830
5831 #-> CPAN::Distribution::is_dot_dist
5832 sub is_dot_dist {
5833     my($self) = @_;
5834     return substr($self->id,-1,1) eq ".";
5835 }
5836
5837 # add the A/AN/ stuff
5838 #-> CPAN::Distribution::normalize
5839 sub normalize {
5840     my($self,$s) = @_;
5841     $s = $self->id unless defined $s;
5842     if (substr($s,-1,1) eq ".") {
5843         # using a global because we are sometimes called as static method
5844         if (!$CPAN::META->{LOCK}
5845             && !$CPAN::Have_warned->{"$s is unlocked"}++
5846            ) {
5847             $CPAN::Frontend->mywarn("You are visiting the local directory
5848   '$s'
5849   without lock, take care that concurrent processes do not do likewise.\n");
5850             $CPAN::Frontend->mysleep(1);
5851         }
5852         if ($s eq ".") {
5853             $s = "$CPAN::iCwd/.";
5854         } elsif (File::Spec->file_name_is_absolute($s)) {
5855         } elsif (File::Spec->can("rel2abs")) {
5856             $s = File::Spec->rel2abs($s);
5857         } else {
5858             $CPAN::Frontend->mydie("Your File::Spec is too old, please upgrade File::Spec");
5859         }
5860         CPAN->debug("s[$s]") if $CPAN::DEBUG;
5861         unless ($CPAN::META->exists("CPAN::Distribution", $s)) {
5862             for ($CPAN::META->instance("CPAN::Distribution", $s)) {
5863                 $_->{build_dir} = $s;
5864                 $_->{archived} = "local_directory";
5865                 $_->{unwrapped} = CPAN::Distrostatus->new("YES -- local_directory");
5866             }
5867         }
5868     } elsif (
5869         $s =~ tr|/|| == 1
5870         or
5871         $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
5872        ) {
5873         return $s if $s =~ m:^N/A|^Contact Author: ;
5874         $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
5875             $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
5876         CPAN->debug("s[$s]") if $CPAN::DEBUG;
5877     }
5878     $s;
5879 }
5880
5881 #-> sub CPAN::Distribution::author ;
5882 sub author {
5883     my($self) = @_;
5884     my($authorid);
5885     if (substr($self->id,-1,1) eq ".") {
5886         $authorid = "LOCAL";
5887     } else {
5888         ($authorid) = $self->pretty_id =~ /^([\w\-]+)/;
5889     }
5890     CPAN::Shell->expand("Author",$authorid);
5891 }
5892
5893 # tries to get the yaml from CPAN instead of the distro itself:
5894 # EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels
5895 sub fast_yaml {
5896     my($self) = @_;
5897     my $meta = $self->pretty_id;
5898     $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/;
5899     my(@ls) = CPAN::Shell->globls($meta);
5900     my $norm = $self->normalize($meta);
5901
5902     my($local_file);
5903     my($local_wanted) =
5904         File::Spec->catfile(
5905                             $CPAN::Config->{keep_source_where},
5906                             "authors",
5907                             "id",
5908                             split(/\//,$norm)
5909                            );
5910     $self->debug("Doing localize") if $CPAN::DEBUG;
5911     unless ($local_file =
5912             CPAN::FTP->localize("authors/id/$norm",
5913                                 $local_wanted)) {
5914         $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n");
5915     }
5916     my $yaml = CPAN->_yaml_loadfile($local_file)->[0];
5917 }
5918
5919 #-> sub CPAN::Distribution::cpan_userid
5920 sub cpan_userid {
5921     my $self = shift;
5922     if ($self->{ID} =~ m{[A-Z]/[A-Z\-]{2}/([A-Z\-]+)/}) {
5923         return $1;
5924     }
5925     return $self->SUPER::cpan_userid;
5926 }
5927
5928 #-> sub CPAN::Distribution::pretty_id
5929 sub pretty_id {
5930     my $self = shift;
5931     my $id = $self->id;
5932     return $id unless $id =~ m|^./../|;
5933     substr($id,5);
5934 }
5935
5936 #-> sub CPAN::Distribution::base_id
5937 sub base_id {
5938     my $self = shift;
5939     my $id = $self->pretty_id();
5940     my $base_id = File::Basename::basename($id);
5941     $base_id =~ s{\.(?:tar\.(bz2|gz|Z)|t(?:gz|bz)|zip)$}{}i;
5942     return $base_id;
5943 }
5944
5945 # mark as dirty/clean for the sake of recursion detection. $color=1
5946 # means "in use", $color=0 means "not in use anymore". $color=2 means
5947 # we have determined prereqs now and thus insist on passing this
5948 # through (at least) once again.
5949
5950 #-> sub CPAN::Distribution::color_cmd_tmps ;
5951 sub color_cmd_tmps {
5952     my($self) = shift;
5953     my($depth) = shift || 0;
5954     my($color) = shift || 0;
5955     my($ancestors) = shift || [];
5956     # a distribution needs to recurse into its prereq_pms
5957
5958     return if exists $self->{incommandcolor}
5959         && $color==1
5960         && $self->{incommandcolor}==$color;
5961     if ($depth>=$CPAN::MAX_RECURSION) {
5962         die(CPAN::Exception::RecursiveDependency->new($ancestors));
5963     }
5964     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5965     my $prereq_pm = $self->prereq_pm;
5966     if (defined $prereq_pm) {
5967       PREREQ: for my $pre (keys %{$prereq_pm->{requires}||{}},
5968                            keys %{$prereq_pm->{build_requires}||{}}) {
5969             next PREREQ if $pre eq "perl";
5970             my $premo;
5971             unless ($premo = CPAN::Shell->expand("Module",$pre)) {
5972                 $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n");
5973                 $CPAN::Frontend->mysleep(2);
5974                 next PREREQ;
5975             }
5976             $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5977         }
5978     }
5979     if ($color==0) {
5980         delete $self->{sponsored_mods};
5981
5982         # as we are at the end of a command, we'll give up this
5983         # reminder of a broken test. Other commands may test this guy
5984         # again. Maybe 'badtestcnt' should be renamed to
5985         # 'make_test_failed_within_command'?
5986         delete $self->{badtestcnt};
5987     }
5988     $self->{incommandcolor} = $color;
5989 }
5990
5991 #-> sub CPAN::Distribution::as_string ;
5992 sub as_string {
5993     my $self = shift;
5994     $self->containsmods;
5995     $self->upload_date;
5996     $self->SUPER::as_string(@_);
5997 }
5998
5999 #-> sub CPAN::Distribution::containsmods ;
6000 sub containsmods {
6001     my $self = shift;
6002     return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
6003     my $dist_id = $self->{ID};
6004     for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
6005         my $mod_file = $mod->cpan_file or next;
6006         my $mod_id = $mod->{ID} or next;
6007         # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
6008         # sleep 1;
6009         if ($CPAN::Signal) {
6010             delete $self->{CONTAINSMODS};
6011             return;
6012         }
6013         $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
6014     }
6015     keys %{$self->{CONTAINSMODS}||{}};
6016 }
6017
6018 #-> sub CPAN::Distribution::upload_date ;
6019 sub upload_date {
6020     my $self = shift;
6021     return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
6022     my(@local_wanted) = split(/\//,$self->id);
6023     my $filename = pop @local_wanted;
6024     push @local_wanted, "CHECKSUMS";
6025     my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
6026     return unless $author;
6027     my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
6028     return unless @dl;
6029     my($dirent) = grep { $_->[2] eq $filename } @dl;
6030     # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
6031     return unless $dirent->[1];
6032     return $self->{UPLOAD_DATE} = $dirent->[1];
6033 }
6034
6035 #-> sub CPAN::Distribution::uptodate ;
6036 sub uptodate {
6037     my($self) = @_;
6038     my $c;
6039     foreach $c ($self->containsmods) {
6040         my $obj = CPAN::Shell->expandany($c);
6041         unless ($obj->uptodate) {
6042             my $id = $self->pretty_id;
6043             $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG;
6044             return 0;
6045         }
6046     }
6047     return 1;
6048 }
6049
6050 #-> sub CPAN::Distribution::called_for ;
6051 sub called_for {
6052     my($self,$id) = @_;
6053     $self->{CALLED_FOR} = $id if defined $id;
6054     return $self->{CALLED_FOR};
6055 }
6056
6057 #-> sub CPAN::Distribution::get ;
6058 sub get {
6059     my($self) = @_;
6060     $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
6061     if (my $goto = $self->prefs->{goto}) {
6062         $CPAN::Frontend->mywarn
6063             (sprintf(
6064                      "delegating to '%s' as specified in prefs file '%s' doc %d\n",
6065                      $goto,
6066                      $self->{prefs_file},
6067                      $self->{prefs_file_doc},
6068                     ));
6069         return $self->goto($goto);
6070     }
6071     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
6072                            ? $ENV{PERL5LIB}
6073                            : ($ENV{PERLLIB} || "");
6074
6075     $CPAN::META->set_perl5lib;
6076     local $ENV{MAKEFLAGS}; # protect us from outer make calls
6077
6078   EXCUSE: {
6079         my @e;
6080         my $goodbye_message;
6081         $self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG;
6082         if ($self->prefs->{disabled}) {
6083             my $why = sprintf(
6084                               "Disabled via prefs file '%s' doc %d",
6085                               $self->{prefs_file},
6086                               $self->{prefs_file_doc},
6087                              );
6088             push @e, $why;
6089             $self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
6090             $goodbye_message = "[disabled] -- NA $why";
6091             # note: not intended to be persistent but at least visible
6092             # during this session
6093         } else {
6094             if (exists $self->{build_dir} && -d $self->{build_dir}
6095                 && ($self->{modulebuild}||$self->{writemakefile})
6096                ) {
6097                 # this deserves print, not warn:
6098                 $CPAN::Frontend->myprint("  Has already been unwrapped into directory ".
6099                                          "$self->{build_dir}\n"
6100                                         );
6101                 return 1;
6102             }
6103
6104             # although we talk about 'force' we shall not test on
6105             # force directly. New model of force tries to refrain from
6106             # direct checking of force.
6107             exists $self->{unwrapped} and (
6108                                            UNIVERSAL::can($self->{unwrapped},"failed") ?
6109                                            $self->{unwrapped}->failed :
6110                                            $self->{unwrapped} =~ /^NO/
6111                                           )
6112                 and push @e, "Unwrapping had some problem, won't try again without force";
6113         }
6114         if (@e) {
6115             $CPAN::Frontend->mywarn(join "", map {"$_\n"} @e);
6116             if ($goodbye_message) {
6117                  $self->goodbye($goodbye_message);
6118             }
6119             return;
6120         }
6121     }
6122     my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
6123
6124     my($local_file);
6125     unless ($self->{build_dir} && -d $self->{build_dir}) {
6126         $self->get_file_onto_local_disk;
6127         return if $CPAN::Signal;
6128         $self->check_integrity;
6129         return if $CPAN::Signal;
6130         (my $packagedir,$local_file) = $self->run_preps_on_packagedir;
6131         $packagedir ||= $self->{build_dir};
6132         $self->{build_dir} = $packagedir;
6133     }
6134
6135     if ($CPAN::Signal) {
6136         $self->safe_chdir($sub_wd);
6137         return;
6138     }
6139     return $self->run_MM_or_MB($local_file);
6140 }
6141
6142 #-> CPAN::Distribution::get_file_onto_local_disk
6143 sub get_file_onto_local_disk {
6144     my($self) = @_;
6145
6146     return if $self->is_dot_dist;
6147     my($local_file);
6148     my($local_wanted) =
6149         File::Spec->catfile(
6150                             $CPAN::Config->{keep_source_where},
6151                             "authors",
6152                             "id",
6153                             split(/\//,$self->id)
6154                            );
6155
6156     $self->debug("Doing localize") if $CPAN::DEBUG;
6157     unless ($local_file =
6158             CPAN::FTP->localize("authors/id/$self->{ID}",
6159                                 $local_wanted)) {
6160         my $note = "";
6161         if ($CPAN::Index::DATE_OF_02) {
6162             $note = "Note: Current database in memory was generated ".
6163                 "on $CPAN::Index::DATE_OF_02\n";
6164         }
6165         $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
6166     }
6167
6168     $self->debug("local_wanted[$local_wanted]local_file[$local_file]") if $CPAN::DEBUG;
6169     $self->{localfile} = $local_file;
6170 }
6171
6172
6173 #-> CPAN::Distribution::check_integrity
6174 sub check_integrity {
6175     my($self) = @_;
6176
6177     return if $self->is_dot_dist;
6178     if ($CPAN::META->has_inst("Digest::SHA")) {
6179         $self->debug("Digest::SHA is installed, verifying");
6180         $self->verifyCHECKSUM;
6181     } else {
6182         $self->debug("Digest::SHA is NOT installed");
6183     }
6184 }
6185
6186 #-> CPAN::Distribution::run_preps_on_packagedir
6187 sub run_preps_on_packagedir {
6188     my($self) = @_;
6189     return if $self->is_dot_dist;
6190
6191     $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
6192     my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
6193     $self->safe_chdir($builddir);
6194     $self->debug("Removing tmp-$$") if $CPAN::DEBUG;
6195     File::Path::rmtree("tmp-$$");
6196     unless (mkdir "tmp-$$", 0755) {
6197         $CPAN::Frontend->unrecoverable_error(<<EOF);
6198 Couldn't mkdir '$builddir/tmp-$$': $!
6199
6200 Cannot continue: Please find the reason why I cannot make the
6201 directory
6202 $builddir/tmp-$$
6203 and fix the problem, then retry.
6204
6205 EOF
6206     }
6207     if ($CPAN::Signal) {
6208         return;
6209     }
6210     $self->safe_chdir("tmp-$$");
6211
6212     #
6213     # Unpack the goods
6214     #
6215     my $local_file = $self->{localfile};
6216     my $ct = eval{CPAN::Tarzip->new($local_file)};
6217     unless ($ct) {
6218         $self->{unwrapped} = CPAN::Distrostatus->new("NO");
6219         delete $self->{build_dir};
6220         return;
6221     }
6222     if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i) {
6223         $self->{was_uncompressed}++ unless eval{$ct->gtest()};
6224         $self->untar_me($ct);
6225     } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
6226         $self->unzip_me($ct);
6227     } else {
6228         $self->{was_uncompressed}++ unless $ct->gtest();
6229         $local_file = $self->handle_singlefile($local_file);
6230     }
6231
6232     # we are still in the tmp directory!
6233     # Let's check if the package has its own directory.
6234     my $dh = DirHandle->new(File::Spec->curdir)
6235         or Carp::croak("Couldn't opendir .: $!");
6236     my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
6237     $dh->close;
6238     my ($packagedir);
6239     # XXX here we want in each branch File::Temp to protect all build_dir directories
6240     if (CPAN->has_inst("File::Temp")) {
6241         my $tdir_base;
6242         my $from_dir;
6243         my @dirents;
6244         if (@readdir == 1 && -d $readdir[0]) {
6245             $tdir_base = $readdir[0];
6246             $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]);
6247             my $dh2 = DirHandle->new($from_dir)
6248                 or Carp::croak("Couldn't opendir $from_dir: $!");
6249             @dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC??
6250         } else {
6251             my $userid = $self->cpan_userid;
6252             CPAN->debug("userid[$userid]");
6253             if (!$userid or $userid eq "N/A") {
6254                 $userid = "anon";
6255             }
6256             $tdir_base = $userid;
6257             $from_dir = File::Spec->curdir;
6258             @dirents = @readdir;
6259         }
6260         $packagedir = File::Temp::tempdir(
6261                                           "$tdir_base-XXXXXX",
6262                                           DIR => $builddir,
6263                                           CLEANUP => 0,
6264                                          );
6265         my $f;
6266         for $f (@dirents) { # is already without "." and ".."
6267             my $from = File::Spec->catdir($from_dir,$f);
6268             my $to = File::Spec->catdir($packagedir,$f);
6269             unless (File::Copy::move($from,$to)) {
6270                 my $err = $!;
6271                 $from = File::Spec->rel2abs($from);
6272                 Carp::confess("Couldn't move $from to $to: $err");
6273             }
6274         }
6275     } else { # older code below, still better than nothing when there is no File::Temp
6276         my($distdir);
6277         if (@readdir == 1 && -d $readdir[0]) {
6278             $distdir = $readdir[0];
6279             $packagedir = File::Spec->catdir($builddir,$distdir);
6280             $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
6281                 if $CPAN::DEBUG;
6282             -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
6283                                                         "$packagedir\n");
6284             File::Path::rmtree($packagedir);
6285             unless (File::Copy::move($distdir,$packagedir)) {
6286                 $CPAN::Frontend->unrecoverable_error(<<EOF);
6287 Couldn't move '$distdir' to '$packagedir': $!
6288
6289 Cannot continue: Please find the reason why I cannot move
6290 $builddir/tmp-$$/$distdir
6291 to
6292 $packagedir
6293 and fix the problem, then retry
6294
6295 EOF
6296             }
6297             $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
6298                                  $distdir,
6299                                  $packagedir,
6300                                  -e $packagedir,
6301                                  -d $packagedir,
6302                                 )) if $CPAN::DEBUG;
6303         } else {
6304             my $userid = $self->cpan_userid;
6305             CPAN->debug("userid[$userid]") if $CPAN::DEBUG;
6306             if (!$userid or $userid eq "N/A") {
6307                 $userid = "anon";
6308             }
6309             my $pragmatic_dir = $userid . '000';
6310             $pragmatic_dir =~ s/\W_//g;
6311             $pragmatic_dir++ while -d "../$pragmatic_dir";
6312             $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
6313             $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
6314             File::Path::mkpath($packagedir);
6315             my($f);
6316             for $f (@readdir) { # is already without "." and ".."
6317                 my $to = File::Spec->catdir($packagedir,$f);
6318                 File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
6319             }
6320         }
6321     }
6322     $self->{build_dir} = $packagedir;
6323     $self->safe_chdir($builddir);
6324     File::Path::rmtree("tmp-$$");
6325
6326     $self->safe_chdir($packagedir);
6327     $self->_signature_business();
6328     $self->safe_chdir($builddir);
6329
6330     return($packagedir,$local_file);
6331 }
6332
6333 #-> sub CPAN::Distribution::parse_meta_yml ;
6334 sub parse_meta_yml {
6335     my($self) = @_;
6336     my $build_dir = $self->{build_dir} or die "PANIC: cannot parse yaml without a build_dir";
6337     my $yaml = File::Spec->catfile($build_dir,"META.yml");
6338     $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
6339     return unless -f $yaml;
6340     my $early_yaml;
6341     eval {
6342         require Parse::Metayaml; # hypothetical
6343         $early_yaml = Parse::Metayaml::LoadFile($yaml)->[0];
6344     };
6345     unless ($early_yaml) {
6346         eval { $early_yaml = CPAN->_yaml_loadfile($yaml)->[0]; };
6347     }
6348     unless ($early_yaml) {
6349         return;
6350     }
6351     return $early_yaml;
6352 }
6353
6354 #-> sub CPAN::Distribution::satisfy_configure_requires ;
6355 sub satisfy_configure_requires {
6356     my($self) = @_;
6357     my $enable_configure_requires = 1;
6358     if (!$enable_configure_requires) {
6359         return 1;
6360         # if we return 1 here, everything is as before we introduced
6361         # configure_requires that means, things with
6362         # configure_requires simply fail, all others succeed
6363     }
6364     my @prereq = $self->unsat_prereq("configure_requires_later") or return 1;
6365     if ($self->{configure_requires_later}) {
6366         for my $k (keys %{$self->{configure_requires_later_for}||{}}) {
6367             if ($self->{configure_requires_later_for}{$k}>1) {
6368                 # we must not come here a second time
6369                 $CPAN::Frontend->mywarn("Panic: Some prerequisites is not available, please investigate...");
6370                 require YAML::Syck;
6371                 $CPAN::Frontend->mydie
6372                     (
6373                      YAML::Syck::Dump
6374                      ({self=>$self, prereq=>\@prereq})
6375                     );
6376             }
6377         }
6378     }
6379     if ($prereq[0][0] eq "perl") {
6380         my $need = "requires perl '$prereq[0][1]'";
6381         my $id = $self->pretty_id;
6382         $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
6383         $self->{make} = CPAN::Distrostatus->new("NO $need");
6384         $self->store_persistent_state;
6385         return $self->goodbye("[prereq] -- NOT OK");
6386     } else {
6387         my $follow = eval {
6388             $self->follow_prereqs("configure_requires_later", @prereq);
6389         };
6390         if (0) {
6391         } elsif ($follow) {
6392             return;
6393         } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
6394             $CPAN::Frontend->mywarn($@);
6395             return $self->goodbye("[depend] -- NOT OK");
6396         }
6397     }
6398     die "never reached";
6399 }
6400
6401 #-> sub CPAN::Distribution::run_MM_or_MB ;
6402 sub run_MM_or_MB {
6403     my($self,$local_file) = @_;
6404     $self->satisfy_configure_requires() or return;
6405     my($mpl) = File::Spec->catfile($self->{build_dir},"Makefile.PL");
6406     my($mpl_exists) = -f $mpl;
6407     unless ($mpl_exists) {
6408         # NFS has been reported to have racing problems after the
6409         # renaming of a directory in some environments.
6410         # This trick helps.
6411         $CPAN::Frontend->mysleep(1);
6412         my $mpldh = DirHandle->new($self->{build_dir})
6413             or Carp::croak("Couldn't opendir $self->{build_dir}: $!");
6414         $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
6415         $mpldh->close;
6416     }
6417     my $prefer_installer = "eumm"; # eumm|mb
6418     if (-f File::Spec->catfile($self->{build_dir},"Build.PL")) {
6419         if ($mpl_exists) { # they *can* choose
6420             if ($CPAN::META->has_inst("Module::Build")) {
6421                 $prefer_installer = CPAN::HandleConfig->prefs_lookup($self,
6422                                                                      q{prefer_installer});
6423             }
6424         } else {
6425             $prefer_installer = "mb";
6426         }
6427     }
6428     return unless $self->patch;
6429     if (lc($prefer_installer) eq "rand") {
6430         $prefer_installer = rand()<.5 ? "eumm" : "mb";
6431     }
6432     if (lc($prefer_installer) eq "mb") {
6433         $self->{modulebuild} = 1;
6434     } elsif ($self->{archived} eq "patch") {
6435         # not an edge case, nothing to install for sure
6436         my $why = "A patch file cannot be installed";
6437         $CPAN::Frontend->mywarn("Refusing to handle this file: $why\n");
6438         $self->{writemakefile} = CPAN::Distrostatus->new("NO $why");
6439     } elsif (! $mpl_exists) {
6440         $self->_edge_cases($mpl,$local_file);
6441     }
6442     if ($self->{build_dir}
6443         &&
6444         $CPAN::Config->{build_dir_reuse}
6445        ) {
6446         $self->store_persistent_state;
6447     }
6448     return $self;
6449 }
6450
6451 #-> CPAN::Distribution::store_persistent_state
6452 sub store_persistent_state {
6453     my($self) = @_;
6454     my $dir = $self->{build_dir};
6455     unless (File::Spec->canonpath(File::Basename::dirname($dir))
6456             eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
6457         $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
6458                                 "will not store persistent state\n");
6459         return;
6460     }
6461     my $file = sprintf "%s.yml", $dir;
6462     my $yaml_module = CPAN::_yaml_module;
6463     if ($CPAN::META->has_inst($yaml_module)) {
6464         CPAN->_yaml_dumpfile(
6465                              $file,
6466                              {
6467                               time => time,
6468                               perl => CPAN::_perl_fingerprint,
6469                               distribution => $self,
6470                              }
6471                             );
6472     } else {
6473         $CPAN::Frontend->myprint("Warning (usually harmless): '$yaml_module' not installed, ".
6474                                 "will not store persistent state\n");
6475     }
6476 }
6477
6478 #-> CPAN::Distribution::patch
6479 sub try_download {
6480     my($self,$patch) = @_;
6481     my $norm = $self->normalize($patch);
6482     my($local_wanted) =
6483         File::Spec->catfile(
6484                             $CPAN::Config->{keep_source_where},
6485                             "authors",
6486                             "id",
6487                             split(/\//,$norm),
6488                            );
6489     $self->debug("Doing localize") if $CPAN::DEBUG;
6490     return CPAN::FTP->localize("authors/id/$norm",
6491                                $local_wanted);
6492 }
6493
6494 {
6495     my $stdpatchargs = "";
6496     #-> CPAN::Distribution::patch
6497     sub patch {
6498         my($self) = @_;
6499         $self->debug("checking patches id[$self->{ID}]") if $CPAN::DEBUG;
6500         my $patches = $self->prefs->{patches};
6501         $patches ||= "";
6502         $self->debug("patches[$patches]") if $CPAN::DEBUG;
6503         if ($patches) {
6504             return unless @$patches;
6505             $self->safe_chdir($self->{build_dir});
6506             CPAN->debug("patches[$patches]") if $CPAN::DEBUG;
6507             my $patchbin = $CPAN::Config->{patch};
6508             unless ($patchbin && length $patchbin) {
6509                 $CPAN::Frontend->mydie("No external patch command configured\n\n".
6510                                        "Please run 'o conf init /patch/'\n\n");
6511             }
6512             unless (MM->maybe_command($patchbin)) {
6513                 $CPAN::Frontend->mydie("No external patch command available\n\n".
6514                                        "Please run 'o conf init /patch/'\n\n");
6515             }
6516             $patchbin = CPAN::HandleConfig->safe_quote($patchbin);
6517             local $ENV{PATCH_GET} = 0; # formerly known as -g0
6518             unless ($stdpatchargs) {
6519                 my $system = "$patchbin --version |";
6520                 local *FH;
6521                 open FH, $system or die "Could not fork '$system': $!";
6522                 local $/ = "\n";
6523                 my $pversion;
6524               PARSEVERSION: while (<FH>) {
6525                     if (/^patch\s+([\d\.]+)/) {
6526                         $pversion = $1;
6527                         last PARSEVERSION;
6528                     }
6529                 }
6530                 if ($pversion) {
6531                     $stdpatchargs = "-N --fuzz=3";
6532                 } else {
6533                     $stdpatchargs = "-N";
6534                 }
6535             }
6536             my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches");
6537             $CPAN::Frontend->myprint("Going to apply $countedpatches:\n");
6538             for my $patch (@$patches) {
6539                 unless (-f $patch) {
6540                     if (my $trydl = $self->try_download($patch)) {
6541                         $patch = $trydl;
6542                     } else {
6543                         my $fail = "Could not find patch '$patch'";
6544                         $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6545                         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6546                         delete $self->{build_dir};
6547                         return;
6548                     }
6549                 }
6550                 $CPAN::Frontend->myprint("  $patch\n");
6551                 my $readfh = CPAN::Tarzip->TIEHANDLE($patch);
6552
6553                 my $pcommand;
6554                 my $ppp = $self->_patch_p_parameter($readfh);
6555                 if ($ppp eq "applypatch") {
6556                     $pcommand = "$CPAN::Config->{applypatch} -verbose";
6557                 } else {
6558                     my $thispatchargs = join " ", $stdpatchargs, $ppp;
6559                     $pcommand = "$patchbin $thispatchargs";
6560                 }
6561
6562                 $readfh = CPAN::Tarzip->TIEHANDLE($patch); # open again
6563                 my $writefh = FileHandle->new;
6564                 $CPAN::Frontend->myprint("  $pcommand\n");
6565                 unless (open $writefh, "|$pcommand") {
6566                     my $fail = "Could not fork '$pcommand'";
6567                     $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6568                     $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6569                     delete $self->{build_dir};
6570                     return;
6571                 }
6572                 while (my $x = $readfh->READLINE) {
6573                     print $writefh $x;
6574                 }
6575                 unless (close $writefh) {
6576                     my $fail = "Could not apply patch '$patch'";
6577                     $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6578                     $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6579                     delete $self->{build_dir};
6580                     return;
6581                 }
6582             }
6583             $self->{patched}++;
6584         }
6585         return 1;
6586     }
6587 }
6588
6589 sub _patch_p_parameter {
6590     my($self,$fh) = @_;
6591     my $cnt_files   = 0;
6592     my $cnt_p0files = 0;
6593     local($_);
6594     while ($_ = $fh->READLINE) {
6595         if (
6596             $CPAN::Config->{applypatch}
6597             &&
6598             /\#\#\#\# ApplyPatch data follows \#\#\#\#/
6599            ) {
6600             return "applypatch"
6601         }
6602         next unless /^[\*\+]{3}\s(\S+)/;
6603         my $file = $1;
6604         $cnt_files++;
6605         $cnt_p0files++ if -f $file;
6606         CPAN->debug("file[$file]cnt_files[$cnt_files]cnt_p0files[$cnt_p0files]")
6607             if $CPAN::DEBUG;
6608     }
6609     return "-p1" unless $cnt_files;
6610     return $cnt_files==$cnt_p0files ? "-p0" : "-p1";
6611 }
6612
6613 #-> sub CPAN::Distribution::_edge_cases
6614 # with "configure" or "Makefile" or single file scripts
6615 sub _edge_cases {
6616     my($self,$mpl,$local_file) = @_;
6617     $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
6618                          $mpl,
6619                          CPAN::anycwd(),
6620                         )) if $CPAN::DEBUG;
6621     my $build_dir = $self->{build_dir};
6622     my($configure) = File::Spec->catfile($build_dir,"Configure");
6623     if (-f $configure) {
6624         # do we have anything to do?
6625         $self->{configure} = $configure;
6626     } elsif (-f File::Spec->catfile($build_dir,"Makefile")) {
6627         $CPAN::Frontend->mywarn(qq{
6628 Package comes with a Makefile and without a Makefile.PL.
6629 We\'ll try to build it with that Makefile then.
6630 });
6631         $self->{writemakefile} = CPAN::Distrostatus->new("YES");
6632         $CPAN::Frontend->mysleep(2);
6633     } else {
6634         my $cf = $self->called_for || "unknown";
6635         if ($cf =~ m|/|) {
6636             $cf =~ s|.*/||;
6637             $cf =~ s|\W.*||;
6638         }
6639         $cf =~ s|[/\\:]||g;     # risk of filesystem damage
6640         $cf = "unknown" unless length($cf);
6641         $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
6642   (The test -f "$mpl" returned false.)
6643   Writing one on our own (setting NAME to $cf)\a\n});
6644         $self->{had_no_makefile_pl}++;
6645         $CPAN::Frontend->mysleep(3);
6646
6647         # Writing our own Makefile.PL
6648
6649         my $script = "";
6650         if ($self->{archived} eq "maybe_pl") {
6651             my $fh = FileHandle->new;
6652             my $script_file = File::Spec->catfile($build_dir,$local_file);
6653             $fh->open($script_file)
6654                 or Carp::croak("Could not open script '$script_file': $!");
6655             local $/ = "\n";
6656             # name parsen und prereq
6657             my($state) = "poddir";
6658             my($name, $prereq) = ("", "");
6659             while (<$fh>) {
6660                 if ($state eq "poddir" && /^=head\d\s+(\S+)/) {
6661                     if ($1 eq 'NAME') {
6662                         $state = "name";
6663                     } elsif ($1 eq 'PREREQUISITES') {
6664                         $state = "prereq";
6665                     }
6666                 } elsif ($state =~ m{^(name|prereq)$}) {
6667                     if (/^=/) {
6668                         $state = "poddir";
6669                     } elsif (/^\s*$/) {
6670                         # nop
6671                     } elsif ($state eq "name") {
6672                         if ($name eq "") {
6673                             ($name) = /^(\S+)/;
6674                             $state = "poddir";
6675                         }
6676                     } elsif ($state eq "prereq") {
6677                         $prereq .= $_;
6678                     }
6679                 } elsif (/^=cut\b/) {
6680                     last;
6681                 }
6682             }
6683             $fh->close;
6684
6685             for ($name) {
6686                 s{.*<}{};       # strip X<...>
6687                 s{>.*}{};
6688             }
6689             chomp $prereq;
6690             $prereq = join " ", split /\s+/, $prereq;
6691             my($PREREQ_PM) = join("\n", map {
6692                 s{.*<}{};       # strip X<...>
6693                 s{>.*}{};
6694                 if (/[\s\'\"]/) { # prose?
6695                 } else {
6696                     s/[^\w:]$//; # period?
6697                     " "x28 . "'$_' => 0,";
6698                 }
6699             } split /\s*,\s*/, $prereq);
6700
6701             $script = "
6702               EXE_FILES => ['$name'],
6703               PREREQ_PM => {
6704 $PREREQ_PM
6705                            },
6706 ";
6707             if ($name) {
6708                 my $to_file = File::Spec->catfile($build_dir, $name);
6709                 rename $script_file, $to_file
6710                     or die "Can't rename $script_file to $to_file: $!";
6711             }
6712         }
6713
6714         my $fh = FileHandle->new;
6715         $fh->open(">$mpl")
6716             or Carp::croak("Could not open >$mpl: $!");
6717         $fh->print(
6718                    qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
6719 # because there was no Makefile.PL supplied.
6720 # Autogenerated on: }.scalar localtime().qq{
6721
6722 use ExtUtils::MakeMaker;
6723 WriteMakefile(
6724               NAME => q[$cf],$script
6725              );
6726 });
6727         $fh->close;
6728     }
6729 }
6730
6731 #-> CPAN::Distribution::_signature_business
6732 sub _signature_business {
6733     my($self) = @_;
6734     my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
6735                                                       q{check_sigs});
6736     if ($check_sigs) {
6737         if ($CPAN::META->has_inst("Module::Signature")) {
6738             if (-f "SIGNATURE") {
6739                 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
6740                 my $rv = Module::Signature::verify();
6741                 if ($rv != Module::Signature::SIGNATURE_OK() and
6742                     $rv != Module::Signature::SIGNATURE_MISSING()) {
6743                     $CPAN::Frontend->mywarn(
6744                                             qq{\nSignature invalid for }.
6745                                             qq{distribution file. }.
6746                                             qq{Please investigate.\n\n}
6747                                            );
6748
6749                     my $wrap =
6750                         sprintf(qq{I'd recommend removing %s. Some error occured    }.
6751                                 qq{while checking its signature, so it could        }.
6752                                 qq{be invalid. Maybe you have configured            }.
6753                                 qq{your 'urllist' with a bad URL. Please check this }.
6754                                 qq{array with 'o conf urllist' and retry. Or        }.
6755                                 qq{examine the distribution in a subshell. Try
6756   look %s
6757 and run
6758   cpansign -v
6759 },
6760                                 $self->{localfile},
6761                                 $self->pretty_id,
6762                                );
6763                     $self->{signature_verify} = CPAN::Distrostatus->new("NO");
6764                     $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
6765                     $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
6766                 } else {
6767                     $self->{signature_verify} = CPAN::Distrostatus->new("YES");
6768                     $self->debug("Module::Signature has verified") if $CPAN::DEBUG;
6769                 }
6770             } else {
6771                 $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n});
6772             }
6773         } else {
6774             $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
6775         }
6776     }
6777 }
6778
6779 #-> CPAN::Distribution::untar_me ;
6780 sub untar_me {
6781     my($self,$ct) = @_;
6782     $self->{archived} = "tar";
6783     if ($ct->untar()) {
6784         $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6785     } else {
6786         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed");
6787     }
6788 }
6789
6790 # CPAN::Distribution::unzip_me ;
6791 sub unzip_me {
6792     my($self,$ct) = @_;
6793     $self->{archived} = "zip";
6794     if ($ct->unzip()) {
6795         $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6796     } else {
6797         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed");
6798     }
6799     return;
6800 }
6801
6802 sub handle_singlefile {
6803     my($self,$local_file) = @_;
6804
6805     if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ) {
6806         $self->{archived} = "pm";
6807     } elsif ( $local_file =~ /\.patch(\.(gz|bz2))?(?!\n)\Z/ ) {
6808         $self->{archived} = "patch";
6809     } else {
6810         $self->{archived} = "maybe_pl";
6811     }
6812
6813     my $to = File::Basename::basename($local_file);
6814     if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
6815         if (eval{CPAN::Tarzip->new($local_file)->gunzip($to)}) {
6816             $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6817         } else {
6818             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- uncompressing failed");
6819         }
6820     } else {
6821         if (File::Copy::cp($local_file,".")) {
6822             $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6823         } else {
6824             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed");
6825         }
6826     }
6827     return $to;
6828 }
6829
6830 #-> sub CPAN::Distribution::new ;
6831 sub new {
6832     my($class,%att) = @_;
6833
6834     # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
6835
6836     my $this = { %att };
6837     return bless $this, $class;
6838 }
6839
6840 #-> sub CPAN::Distribution::look ;
6841 sub look {
6842     my($self) = @_;
6843
6844     if ($^O eq 'MacOS') {
6845       $self->Mac::BuildTools::look;
6846       return;
6847     }
6848
6849     if (  $CPAN::Config->{'shell'} ) {
6850         $CPAN::Frontend->myprint(qq{
6851 Trying to open a subshell in the build directory...
6852 });
6853     } else {
6854         $CPAN::Frontend->myprint(qq{
6855 Your configuration does not define a value for subshells.
6856 Please define it with "o conf shell <your shell>"
6857 });
6858         return;
6859     }
6860     my $dist = $self->id;
6861     my $dir;
6862     unless ($dir = $self->dir) {
6863         $self->get;
6864     }
6865     unless ($dir ||= $self->dir) {
6866         $CPAN::Frontend->mywarn(qq{
6867 Could not determine which directory to use for looking at $dist.
6868 });
6869         return;
6870     }
6871     my $pwd  = CPAN::anycwd();
6872     $self->safe_chdir($dir);
6873     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
6874     {
6875         local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
6876         $ENV{CPAN_SHELL_LEVEL} += 1;
6877         my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'});
6878         unless (system($shell) == 0) {
6879             my $code = $? >> 8;
6880             $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
6881         }
6882     }
6883     $self->safe_chdir($pwd);
6884 }
6885
6886 # CPAN::Distribution::cvs_import ;
6887 sub cvs_import {
6888     my($self) = @_;
6889     $self->get;
6890     my $dir = $self->dir;
6891
6892     my $package = $self->called_for;
6893     my $module = $CPAN::META->instance('CPAN::Module', $package);
6894     my $version = $module->cpan_version;
6895
6896     my $userid = $self->cpan_userid;
6897
6898     my $cvs_dir = (split /\//, $dir)[-1];
6899     $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
6900     my $cvs_root =
6901       $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
6902     my $cvs_site_perl =
6903       $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
6904     if ($cvs_site_perl) {
6905         $cvs_dir = "$cvs_site_perl/$cvs_dir";
6906     }
6907     my $cvs_log = qq{"imported $package $version sources"};
6908     $version =~ s/\./_/g;
6909     # XXX cvs: undocumented and unclear how it was meant to work
6910     my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
6911                "$cvs_dir", $userid, "v$version");
6912
6913     my $pwd  = CPAN::anycwd();
6914     chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
6915
6916     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
6917
6918     $CPAN::Frontend->myprint(qq{@cmd\n});
6919     system(@cmd) == 0 or
6920     # XXX cvs
6921         $CPAN::Frontend->mydie("cvs import failed");
6922     chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
6923 }
6924
6925 #-> sub CPAN::Distribution::readme ;
6926 sub readme {
6927     my($self) = @_;
6928     my($dist) = $self->id;
6929     my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
6930     $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
6931     my($local_file);
6932     my($local_wanted) =
6933         File::Spec->catfile(
6934                             $CPAN::Config->{keep_source_where},
6935                             "authors",
6936                             "id",
6937                             split(/\//,"$sans.readme"),
6938                            );
6939     $self->debug("Doing localize") if $CPAN::DEBUG;
6940     $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
6941                                       $local_wanted)
6942         or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
6943
6944     if ($^O eq 'MacOS') {
6945         Mac::BuildTools::launch_file($local_file);
6946         return;
6947     }
6948
6949     my $fh_pager = FileHandle->new;
6950     local($SIG{PIPE}) = "IGNORE";
6951     my $pager = $CPAN::Config->{'pager'} || "cat";
6952     $fh_pager->open("|$pager")
6953         or die "Could not open pager $pager\: $!";
6954     my $fh_readme = FileHandle->new;
6955     $fh_readme->open($local_file)
6956         or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
6957     $CPAN::Frontend->myprint(qq{
6958 Displaying file
6959   $local_file
6960 with pager "$pager"
6961 });
6962     $fh_pager->print(<$fh_readme>);
6963     $fh_pager->close;
6964 }
6965
6966 #-> sub CPAN::Distribution::verifyCHECKSUM ;
6967 sub verifyCHECKSUM {
6968     my($self) = @_;
6969   EXCUSE: {
6970         my @e;
6971         $self->{CHECKSUM_STATUS} ||= "";
6972         $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
6973         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
6974     }
6975     my($lc_want,$lc_file,@local,$basename);
6976     @local = split(/\//,$self->id);
6977     pop @local;
6978     push @local, "CHECKSUMS";
6979     $lc_want =
6980         File::Spec->catfile($CPAN::Config->{keep_source_where},
6981                             "authors", "id", @local);
6982     local($") = "/";
6983     if (my $size = -s $lc_want) {
6984         $self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG;
6985         if ($self->CHECKSUM_check_file($lc_want,1)) {
6986             return $self->{CHECKSUM_STATUS} = "OK";
6987         }
6988     }
6989     $lc_file = CPAN::FTP->localize("authors/id/@local",
6990                                    $lc_want,1);
6991     unless ($lc_file) {
6992         $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
6993         $local[-1] .= ".gz";
6994         $lc_file = CPAN::FTP->localize("authors/id/@local",
6995                                        "$lc_want.gz",1);
6996         if ($lc_file) {
6997             $lc_file =~ s/\.gz(?!\n)\Z//;
6998             eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
6999         } else {
7000             return;
7001         }
7002     }
7003     if ($self->CHECKSUM_check_file($lc_file)) {
7004         return $self->{CHECKSUM_STATUS} = "OK";
7005     }
7006 }
7007
7008 #-> sub CPAN::Distribution::SIG_check_file ;
7009 sub SIG_check_file {
7010     my($self,$chk_file) = @_;
7011     my $rv = eval { Module::Signature::_verify($chk_file) };
7012
7013     if ($rv == Module::Signature::SIGNATURE_OK()) {
7014         $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
7015         return $self->{SIG_STATUS} = "OK";
7016     } else {
7017         $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
7018                                  qq{distribution file. }.
7019                                  qq{Please investigate.\n\n}.
7020                                  $self->as_string,
7021                                  $CPAN::META->instance(
7022                                                        'CPAN::Author',
7023                                                        $self->cpan_userid
7024                                                       )->as_string);
7025
7026         my $wrap = qq{I\'d recommend removing $chk_file. Its signature
7027 is invalid. Maybe you have configured your 'urllist' with
7028 a bad URL. Please check this array with 'o conf urllist', and
7029 retry.};
7030
7031         $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
7032     }
7033 }
7034
7035 #-> sub CPAN::Distribution::CHECKSUM_check_file ;
7036
7037 # sloppy is 1 when we have an old checksums file that maybe is good
7038 # enough
7039
7040 sub CHECKSUM_check_file {
7041     my($self,$chk_file,$sloppy) = @_;
7042     my($cksum,$file,$basename);
7043
7044     $sloppy ||= 0;
7045     $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG;
7046     my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
7047                                                       q{check_sigs});
7048     if ($check_sigs) {
7049         if ($CPAN::META->has_inst("Module::Signature")) {
7050             $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
7051             $self->SIG_check_file($chk_file);
7052         } else {
7053             $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
7054         }
7055     }
7056
7057     $file = $self->{localfile};
7058     $basename = File::Basename::basename($file);
7059     my $fh = FileHandle->new;
7060     if (open $fh, $chk_file) {
7061         local($/);
7062         my $eval = <$fh>;
7063         $eval =~ s/\015?\012/\n/g;
7064         close $fh;
7065         my($comp) = Safe->new();
7066         $cksum = $comp->reval($eval);
7067         if ($@) {
7068             rename $chk_file, "$chk_file.bad";
7069             Carp::confess($@) if $@;
7070         }
7071     } else {
7072         Carp::carp "Could not open $chk_file for reading";
7073     }
7074
7075     if (! ref $cksum or ref $cksum ne "HASH") {
7076         $CPAN::Frontend->mywarn(qq{
7077 Warning: checksum file '$chk_file' broken.
7078
7079 When trying to read that file I expected to get a hash reference
7080 for further processing, but got garbage instead.
7081 });
7082         my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
7083         $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
7084         $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken";
7085         return;
7086     } elsif (exists $cksum->{$basename}{sha256}) {
7087         $self->debug("Found checksum for $basename:" .
7088                      "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
7089
7090         open($fh, $file);
7091         binmode $fh;
7092         my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
7093         $fh->close;
7094         $fh = CPAN::Tarzip->TIEHANDLE($file);
7095
7096         unless ($eq) {
7097             my $dg = Digest::SHA->new(256);
7098             my($data,$ref);
7099             $ref = \$data;
7100             while ($fh->READ($ref, 4096) > 0) {
7101                 $dg->add($data);
7102             }
7103             my $hexdigest = $dg->hexdigest;
7104             $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
7105         }
7106
7107         if ($eq) {
7108             $CPAN::Frontend->myprint("Checksum for $file ok\n");
7109             return $self->{CHECKSUM_STATUS} = "OK";
7110         } else {
7111             $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
7112                                      qq{distribution file. }.
7113                                      qq{Please investigate.\n\n}.
7114                                      $self->as_string,
7115                                      $CPAN::META->instance(
7116                                                            'CPAN::Author',
7117                                                            $self->cpan_userid
7118                                                           )->as_string);
7119
7120             my $wrap = qq{I\'d recommend removing $file. Its
7121 checksum is incorrect. Maybe you have configured your 'urllist' with
7122 a bad URL. Please check this array with 'o conf urllist', and
7123 retry.};
7124
7125             $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
7126
7127             # former versions just returned here but this seems a
7128             # serious threat that deserves a die
7129
7130             # $CPAN::Frontend->myprint("\n\n");
7131             # sleep 3;
7132             # return;
7133         }
7134         # close $fh if fileno($fh);
7135     } else {
7136         return if $sloppy;
7137         unless ($self->{CHECKSUM_STATUS}) {
7138             $CPAN::Frontend->mywarn(qq{
7139 Warning: No checksum for $basename in $chk_file.
7140
7141 The cause for this may be that the file is very new and the checksum
7142 has not yet been calculated, but it may also be that something is
7143 going awry right now.
7144 });
7145             my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes");
7146             $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
7147         }
7148         $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file";
7149         return;
7150     }
7151 }
7152
7153 #-> sub CPAN::Distribution::eq_CHECKSUM ;
7154 sub eq_CHECKSUM {
7155     my($self,$fh,$expect) = @_;
7156     if ($CPAN::META->has_inst("Digest::SHA")) {
7157         my $dg = Digest::SHA->new(256);
7158         my($data);
7159         while (read($fh, $data, 4096)) {
7160             $dg->add($data);
7161         }
7162         my $hexdigest = $dg->hexdigest;
7163         # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
7164         return $hexdigest eq $expect;
7165     }
7166     return 1;
7167 }
7168
7169 #-> sub CPAN::Distribution::force ;
7170
7171 # Both CPAN::Modules and CPAN::Distributions know if "force" is in
7172 # effect by autoinspection, not by inspecting a global variable. One
7173 # of the reason why this was chosen to work that way was the treatment
7174 # of dependencies. They should not automatically inherit the force
7175 # status. But this has the downside that ^C and die() will return to
7176 # the prompt but will not be able to reset the force_update
7177 # attributes. We try to correct for it currently in the read_metadata
7178 # routine, and immediately before we check for a Signal. I hope this
7179 # works out in one of v1.57_53ff
7180
7181 # "Force get forgets previous error conditions"
7182
7183 #-> sub CPAN::Distribution::fforce ;
7184 sub fforce {
7185   my($self, $method) = @_;
7186   $self->force($method,1);
7187 }
7188
7189 #-> sub CPAN::Distribution::force ;
7190 sub force {
7191   my($self, $method,$fforce) = @_;
7192   my %phase_map = (
7193                    get => [
7194                            "unwrapped",
7195                            "build_dir",
7196                            "archived",
7197                            "localfile",
7198                            "CHECKSUM_STATUS",
7199                            "signature_verify",
7200                            "prefs",
7201                            "prefs_file",
7202                            "prefs_file_doc",
7203                           ],
7204                    make => [
7205                             "writemakefile",
7206                             "make",
7207                             "modulebuild",
7208                             "prereq_pm",
7209                             "prereq_pm_detected",
7210                            ],
7211                    test => [
7212                             "badtestcnt",
7213                             "make_test",
7214                            ],
7215                    install => [
7216                                "install",
7217                               ],
7218                    unknown => [
7219                                "reqtype",
7220                                "yaml_content",
7221                               ],
7222                   );
7223   my $methodmatch = 0;
7224   my $ldebug = 0;
7225  PHASE: for my $phase (qw(unknown get make test install)) { # order matters
7226       $methodmatch = 1 if $fforce || $phase eq $method;
7227       next unless $methodmatch;
7228     ATTRIBUTE: for my $att (@{$phase_map{$phase}}) {
7229           if ($phase eq "get") {
7230               if (substr($self->id,-1,1) eq "."
7231                   && $att =~ /(unwrapped|build_dir|archived)/ ) {
7232                   # cannot be undone for local distros
7233                   next ATTRIBUTE;
7234               }
7235               if ($att eq "build_dir"
7236                   && $self->{build_dir}
7237                   && $CPAN::META->{is_tested}
7238                  ) {
7239                   delete $CPAN::META->{is_tested}{$self->{build_dir}};
7240               }
7241           } elsif ($phase eq "test") {
7242               if ($att eq "make_test"
7243                   && $self->{make_test}
7244                   && $self->{make_test}{COMMANDID}
7245                   && $self->{make_test}{COMMANDID} == $CPAN::CurrentCommandId
7246                  ) {
7247                   # endless loop too likely
7248                   next ATTRIBUTE;
7249               }
7250           }
7251           delete $self->{$att};
7252           if ($ldebug || $CPAN::DEBUG) {
7253               # local $CPAN::DEBUG = 16; # Distribution
7254               CPAN->debug(sprintf "id[%s]phase[%s]att[%s]", $self->id, $phase, $att);
7255           }
7256       }
7257   }
7258   if ($method && $method =~ /make|test|install/) {
7259     $self->{force_update} = 1; # name should probably have been force_install
7260   }
7261 }
7262
7263 #-> sub CPAN::Distribution::notest ;
7264 sub notest {
7265   my($self, $method) = @_;
7266   # $CPAN::Frontend->mywarn("XDEBUG: set notest for $self $method");
7267   $self->{"notest"}++; # name should probably have been force_install
7268 }
7269
7270 #-> sub CPAN::Distribution::unnotest ;
7271 sub unnotest {
7272   my($self) = @_;
7273   # warn "XDEBUG: deleting notest";
7274   delete $self->{notest};
7275 }
7276
7277 #-> sub CPAN::Distribution::unforce ;
7278 sub unforce {
7279   my($self) = @_;
7280   delete $self->{force_update};
7281 }
7282
7283 #-> sub CPAN::Distribution::isa_perl ;
7284 sub isa_perl {
7285   my($self) = @_;
7286   my $file = File::Basename::basename($self->id);
7287   if ($file =~ m{ ^ perl
7288                   -?
7289                   (5)
7290                   ([._-])
7291                   (
7292                    \d{3}(_[0-4][0-9])?
7293                    |
7294                    \d+\.\d+
7295                   )
7296                   \.tar[._-](?:gz|bz2)
7297                   (?!\n)\Z
7298                 }xs) {
7299     return "$1.$3";
7300   } elsif ($self->cpan_comment
7301            &&
7302            $self->cpan_comment =~ /isa_perl\(.+?\)/) {
7303     return $1;
7304   }
7305 }
7306
7307
7308 #-> sub CPAN::Distribution::perl ;
7309 sub perl {
7310     my ($self) = @_;
7311     if (! $self) {
7312         use Carp qw(carp);
7313         carp __PACKAGE__ . "::perl was called without parameters.";
7314     }
7315     return CPAN::HandleConfig->safe_quote($CPAN::Perl);
7316 }
7317
7318
7319 #-> sub CPAN::Distribution::make ;
7320 sub make {
7321     my($self) = @_;
7322     if (my $goto = $self->prefs->{goto}) {
7323         return $self->goto($goto);
7324     }
7325     my $make = $self->{modulebuild} ? "Build" : "make";
7326     # Emergency brake if they said install Pippi and get newest perl
7327     if ($self->isa_perl) {
7328         if (
7329             $self->called_for ne $self->id &&
7330             ! $self->{force_update}
7331         ) {
7332             # if we die here, we break bundles
7333             $CPAN::Frontend
7334                 ->mywarn(sprintf(
7335                             qq{The most recent version "%s" of the module "%s"
7336 is part of the perl-%s distribution. To install that, you need to run
7337   force install %s   --or--
7338   install %s
7339 },
7340                              $CPAN::META->instance(
7341                                                    'CPAN::Module',
7342                                                    $self->called_for
7343                                                   )->cpan_version,
7344                              $self->called_for,
7345                              $self->isa_perl,
7346                              $self->called_for,
7347                              $self->id,
7348                             ));
7349             $self->{make} = CPAN::Distrostatus->new("NO isa perl");
7350             $CPAN::Frontend->mysleep(1);
7351             return;
7352         }
7353     }
7354     $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
7355     $self->get;
7356     if ($self->{configure_requires_later}) {
7357         return;
7358     }
7359     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
7360                            ? $ENV{PERL5LIB}
7361                            : ($ENV{PERLLIB} || "");
7362     $CPAN::META->set_perl5lib;
7363     local $ENV{MAKEFLAGS}; # protect us from outer make calls
7364
7365     if ($CPAN::Signal) {
7366         delete $self->{force_update};
7367         return;
7368     }
7369
7370     my $builddir;
7371   EXCUSE: {
7372         my @e;
7373         if (!$self->{archived} || $self->{archived} eq "NO") {
7374             push @e, "Is neither a tar nor a zip archive.";
7375         }
7376
7377         if (!$self->{unwrapped}
7378             || (
7379                 UNIVERSAL::can($self->{unwrapped},"failed") ?
7380                 $self->{unwrapped}->failed :
7381                 $self->{unwrapped} =~ /^NO/
7382                )) {
7383             push @e, "Had problems unarchiving. Please build manually";
7384         }
7385
7386         unless ($self->{force_update}) {
7387             exists $self->{signature_verify} and
7388                 (
7389                  UNIVERSAL::can($self->{signature_verify},"failed") ?
7390                  $self->{signature_verify}->failed :
7391                  $self->{signature_verify} =~ /^NO/
7392                 )
7393                 and push @e, "Did not pass the signature test.";
7394         }
7395
7396         if (exists $self->{writemakefile} &&
7397             (
7398              UNIVERSAL::can($self->{writemakefile},"failed") ?
7399              $self->{writemakefile}->failed :
7400              $self->{writemakefile} =~ /^NO/
7401             )) {
7402             # XXX maybe a retry would be in order?
7403             my $err = UNIVERSAL::can($self->{writemakefile},"text") ?
7404                 $self->{writemakefile}->text :
7405                     $self->{writemakefile};
7406             $err =~ s/^NO\s*//;
7407             $err ||= "Had some problem writing Makefile";
7408             $err .= ", won't make";
7409             push @e, $err;
7410         }
7411
7412         if (defined $self->{make}) {
7413             if (UNIVERSAL::can($self->{make},"failed") ?
7414                 $self->{make}->failed :
7415                 $self->{make} =~ /^NO/) {
7416                 if ($self->{force_update}) {
7417                     # Trying an already failed 'make' (unless somebody else blocks)
7418                 } else {
7419                     # introduced for turning recursion detection into a distrostatus
7420                     my $error = length $self->{make}>3
7421                         ? substr($self->{make},3) : "Unknown error";
7422                     $CPAN::Frontend->mywarn("Could not make: $error\n");
7423                     $self->store_persistent_state;
7424                     return;
7425                 }
7426             } else {
7427                 push @e, "Has already been made";
7428             }
7429         }
7430
7431         my $later = $self->{later} || $self->{configure_requires_later};
7432         if ($later) { # see also undelay
7433             if ($later) {
7434                 push @e, $later;
7435             }
7436         }
7437
7438         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
7439         $builddir = $self->dir or
7440             $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
7441         unless (chdir $builddir) {
7442             push @e, "Couldn't chdir to '$builddir': $!";
7443         }
7444         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
7445     }
7446     if ($CPAN::Signal) {
7447         delete $self->{force_update};
7448         return;
7449     }
7450     $CPAN::Frontend->myprint("\n  CPAN.pm: Going to build ".$self->id."\n\n");
7451     $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
7452
7453     if ($^O eq 'MacOS') {
7454         Mac::BuildTools::make($self);
7455         return;
7456     }
7457
7458     my %env;
7459     while (my($k,$v) = each %ENV) {
7460         next unless defined $v;
7461         $env{$k} = $v;
7462     }
7463     local %ENV = %env;
7464     my $system;
7465     if (my $commandline = $self->prefs->{pl}{commandline}) {
7466         $system = $commandline;
7467         $ENV{PERL} = $^X;
7468     } elsif ($self->{'configure'}) {
7469         $system = $self->{'configure'};
7470     } elsif ($self->{modulebuild}) {
7471         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
7472         $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}";
7473     } else {
7474         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
7475         my $switch = "";
7476 # This needs a handler that can be turned on or off:
7477 #        $switch = "-MExtUtils::MakeMaker ".
7478 #            "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
7479 #            if $] > 5.00310;
7480         my $makepl_arg = $self->make_x_arg("pl");
7481         $ENV{PERL5_CPAN_IS_EXECUTING} = File::Spec->catfile($self->{build_dir},
7482                                                             "Makefile.PL");
7483         $system = sprintf("%s%s Makefile.PL%s",
7484                           $perl,
7485                           $switch ? " $switch" : "",
7486                           $makepl_arg ? " $makepl_arg" : "",
7487                          );
7488     }
7489     if (my $env = $self->prefs->{pl}{env}) {
7490         for my $e (keys %$env) {
7491             $ENV{$e} = $env->{$e};
7492         }
7493     }
7494     if (exists $self->{writemakefile}) {
7495     } else {
7496         local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
7497         my($ret,$pid,$output);
7498         $@ = "";
7499         my $go_via_alarm;
7500         if ($CPAN::Config->{inactivity_timeout}) {
7501             require Config;
7502             if ($Config::Config{d_alarm}
7503                 &&
7504                 $Config::Config{d_alarm} eq "define"
7505                ) {
7506                 $go_via_alarm++
7507             } else {
7508                 $CPAN::Frontend->mywarn("Warning: you have configured the config ".
7509                                         "variable 'inactivity_timeout' to ".
7510                                         "'$CPAN::Config->{inactivity_timeout}'. But ".
7511                                         "on this machine the system call 'alarm' ".
7512                                         "isn't available. This means that we cannot ".
7513                                         "provide the feature of intercepting long ".
7514                                         "waiting code and will turn this feature off.\n"
7515                                        );
7516                 $CPAN::Config->{inactivity_timeout} = 0;
7517             }
7518         }
7519         if ($go_via_alarm) {
7520             if ( $self->_should_report('pl') ) {
7521                 ($output, $ret) = CPAN::Reporter::record_command(
7522                     $system,
7523                     $CPAN::Config->{inactivity_timeout},
7524                 );
7525                 CPAN::Reporter::grade_PL( $self, $system, $output, $ret );
7526             }
7527             else {
7528                 eval {
7529                     alarm $CPAN::Config->{inactivity_timeout};
7530                     local $SIG{CHLD}; # = sub { wait };
7531                     if (defined($pid = fork)) {
7532                         if ($pid) { #parent
7533                             # wait;
7534                             waitpid $pid, 0;
7535                         } else {    #child
7536                             # note, this exec isn't necessary if
7537                             # inactivity_timeout is 0. On the Mac I'd
7538                             # suggest, we set it always to 0.
7539                             exec $system;
7540                         }
7541                     } else {
7542                         $CPAN::Frontend->myprint("Cannot fork: $!");
7543                         return;
7544                     }
7545                 };
7546                 alarm 0;
7547                 if ($@) {
7548                     kill 9, $pid;
7549                     waitpid $pid, 0;
7550                     my $err = "$@";
7551                     $CPAN::Frontend->myprint($err);
7552                     $self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
7553                     $@ = "";
7554                     $self->store_persistent_state;
7555                     return $self->goodbye("$system -- TIMED OUT");
7556                 }
7557             }
7558         } else {
7559             if (my $expect_model = $self->_prefs_with_expect("pl")) {
7560                 # XXX probably want to check _should_report here and warn
7561                 # about not being able to use CPAN::Reporter with expect
7562                 $ret = $self->_run_via_expect($system,$expect_model);
7563                 if (! defined $ret
7564                     && $self->{writemakefile}
7565                     && $self->{writemakefile}->failed) {
7566                     # timeout
7567                     return;
7568                 }
7569             }
7570             elsif ( $self->_should_report('pl') ) {
7571                 ($output, $ret) = CPAN::Reporter::record_command($system);
7572                 CPAN::Reporter::grade_PL( $self, $system, $output, $ret );
7573             }
7574             else {
7575                 $ret = system($system);
7576             }
7577             if ($ret != 0) {
7578                 $self->{writemakefile} = CPAN::Distrostatus
7579                     ->new("NO '$system' returned status $ret");
7580                 $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
7581                 $self->store_persistent_state;
7582                 return $self->goodbye("$system -- NOT OK");
7583             }
7584         }
7585         if (-f "Makefile" || -f "Build") {
7586             $self->{writemakefile} = CPAN::Distrostatus->new("YES");
7587             delete $self->{make_clean}; # if cleaned before, enable next
7588         } else {
7589             my $makefile = $self->{modulebuild} ? "Build" : "Makefile";
7590             $self->{writemakefile} = CPAN::Distrostatus
7591                 ->new(qq{NO -- No $makefile created});
7592             $self->store_persistent_state;
7593             return $self->goodbye("$system -- NO $makefile created");
7594         }
7595     }
7596     if ($CPAN::Signal) {
7597         delete $self->{force_update};
7598         return;
7599     }
7600     if (my @prereq = $self->unsat_prereq("later")) {
7601         if ($prereq[0][0] eq "perl") {
7602             my $need = "requires perl '$prereq[0][1]'";
7603             my $id = $self->pretty_id;
7604             $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
7605             $self->{make} = CPAN::Distrostatus->new("NO $need");
7606             $self->store_persistent_state;
7607             return $self->goodbye("[prereq] -- NOT OK");
7608         } else {
7609             my $follow = eval { $self->follow_prereqs("later",@prereq); };
7610             if (0) {
7611             } elsif ($follow) {
7612                 # signal success to the queuerunner
7613                 return 1;
7614             } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
7615                 $CPAN::Frontend->mywarn($@);
7616                 return $self->goodbye("[depend] -- NOT OK");
7617             }
7618         }
7619     }
7620     if ($CPAN::Signal) {
7621         delete $self->{force_update};
7622         return;
7623     }
7624     if (my $commandline = $self->prefs->{make}{commandline}) {
7625         $system = $commandline;
7626         $ENV{PERL} = $^X;
7627     } else {
7628         if ($self->{modulebuild}) {
7629             unless (-f "Build") {
7630                 my $cwd = CPAN::anycwd();
7631                 $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
7632                                         " in cwd[$cwd]. Danger, Will Robinson!\n");
7633                 $CPAN::Frontend->mysleep(5);
7634             }
7635             $system = join " ", $self->_build_command(), $CPAN::Config->{mbuild_arg};
7636         } else {
7637             $system = join " ", $self->_make_command(),  $CPAN::Config->{make_arg};
7638         }
7639         $system =~ s/\s+$//;
7640         my $make_arg = $self->make_x_arg("make");
7641         $system = sprintf("%s%s",
7642                           $system,
7643                           $make_arg ? " $make_arg" : "",
7644                          );
7645     }
7646     if (my $env = $self->prefs->{make}{env}) { # overriding the local
7647                                                # ENV of PL, not the
7648                                                # outer ENV, but
7649                                                # unlikely to be a risk
7650         for my $e (keys %$env) {
7651             $ENV{$e} = $env->{$e};
7652         }
7653     }
7654     my $expect_model = $self->_prefs_with_expect("make");
7655     my $want_expect = 0;
7656     if ( $expect_model && @{$expect_model->{talk}} ) {
7657         my $can_expect = $CPAN::META->has_inst("Expect");
7658         if ($can_expect) {
7659             $want_expect = 1;
7660         } else {
7661             $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
7662                                     "system()\n");
7663         }
7664     }
7665     my $system_ok;
7666     if ($want_expect) {
7667         # XXX probably want to check _should_report here and
7668         # warn about not being able to use CPAN::Reporter with expect
7669         $system_ok = $self->_run_via_expect($system,$expect_model) == 0;
7670     }
7671     elsif ( $self->_should_report('make') ) {
7672         my ($output, $ret) = CPAN::Reporter::record_command($system);
7673         CPAN::Reporter::grade_make( $self, $system, $output, $ret );
7674         $system_ok = ! $ret;
7675     }
7676     else {
7677         $system_ok = system($system) == 0;
7678     }
7679     $self->introduce_myself;
7680     if ( $system_ok ) {
7681         $CPAN::Frontend->myprint("  $system -- OK\n");
7682         $self->{make} = CPAN::Distrostatus->new("YES");
7683     } else {
7684         $self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
7685         $self->{make} = CPAN::Distrostatus->new("NO");
7686         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
7687     }
7688     $self->store_persistent_state;
7689 }
7690
7691 # CPAN::Distribution::goodbye ;
7692 sub goodbye {
7693     my($self,$goodbye) = @_;
7694     my $id = $self->pretty_id;
7695     $CPAN::Frontend->mywarn("  $id\n  $goodbye\n");
7696     return;
7697 }
7698
7699 # CPAN::Distribution::_run_via_expect ;
7700 sub _run_via_expect {
7701     my($self,$system,$expect_model) = @_;
7702     CPAN->debug("system[$system]expect_model[$expect_model]") if $CPAN::DEBUG;
7703     if ($CPAN::META->has_inst("Expect")) {
7704         my $expo = Expect->new;  # expo Expect object;
7705         $expo->spawn($system);
7706         $expect_model->{mode} ||= "deterministic";
7707         if ($expect_model->{mode} eq "deterministic") {
7708             return $self->_run_via_expect_deterministic($expo,$expect_model);
7709         } elsif ($expect_model->{mode} eq "anyorder") {
7710             return $self->_run_via_expect_anyorder($expo,$expect_model);
7711         } else {
7712             die "Panic: Illegal expect mode: $expect_model->{mode}";
7713         }
7714     } else {
7715         $CPAN::Frontend->mywarn("Expect not installed, falling back to system()\n");
7716         return system($system);
7717     }
7718 }
7719
7720 sub _run_via_expect_anyorder {
7721     my($self,$expo,$expect_model) = @_;
7722     my $timeout = $expect_model->{timeout} || 5;
7723     my $reuse = $expect_model->{reuse};
7724     my @expectacopy = @{$expect_model->{talk}}; # we trash it!
7725     my $but = "";
7726   EXPECT: while () {
7727         my($eof,$ran_into_timeout);
7728         my @match = $expo->expect($timeout,
7729                                   [ eof => sub {
7730                                         $eof++;
7731                                     } ],
7732                                   [ timeout => sub {
7733                                         $ran_into_timeout++;
7734                                     } ],
7735                                   -re => eval"qr{.}",
7736                                  );
7737         if ($match[2]) {
7738             $but .= $match[2];
7739         }
7740         $but .= $expo->clear_accum;
7741         if ($eof) {
7742             $expo->soft_close;
7743             return $expo->exitstatus();
7744         } elsif ($ran_into_timeout) {
7745             # warn "DEBUG: they are asking a question, but[$but]";
7746             for (my $i = 0; $i <= $#expectacopy; $i+=2) {
7747                 my($next,$send) = @expectacopy[$i,$i+1];
7748                 my $regex = eval "qr{$next}";
7749                 # warn "DEBUG: will compare with regex[$regex].";
7750                 if ($but =~ /$regex/) {
7751                     # warn "DEBUG: will send send[$send]";
7752                     $expo->send($send);
7753                     # never allow reusing an QA pair unless they told us
7754                     splice @expectacopy, $i, 2 unless $reuse;
7755                     next EXPECT;
7756                 }
7757             }
7758             my $why = "could not answer a question during the dialog";
7759             $CPAN::Frontend->mywarn("Failing: $why\n");
7760             $self->{writemakefile} =
7761                 CPAN::Distrostatus->new("NO $why");
7762             return;
7763         }
7764     }
7765 }
7766
7767 sub _run_via_expect_deterministic {
7768     my($self,$expo,$expect_model) = @_;
7769     my $ran_into_timeout;
7770     my $timeout = $expect_model->{timeout} || 15; # currently unsettable
7771     my $expecta = $expect_model->{talk};
7772   EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) {
7773         my($re,$send) = @$expecta[$i,$i+1];
7774         CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG;
7775         my $regex = eval "qr{$re}";
7776         $expo->expect($timeout,
7777                       [ eof => sub {
7778                             my $but = $expo->clear_accum;
7779                             $CPAN::Frontend->mywarn("EOF (maybe harmless)
7780 expected[$regex]\nbut[$but]\n\n");
7781                             last EXPECT;
7782                         } ],
7783                       [ timeout => sub {
7784                             my $but = $expo->clear_accum;
7785                             $CPAN::Frontend->mywarn("TIMEOUT
7786 expected[$regex]\nbut[$but]\n\n");
7787                             $ran_into_timeout++;
7788                         } ],
7789                       -re => $regex);
7790         if ($ran_into_timeout) {
7791             # note that the caller expects 0 for success
7792             $self->{writemakefile} =
7793                 CPAN::Distrostatus->new("NO timeout during expect dialog");
7794             return;
7795         }
7796         $expo->send($send);
7797     }
7798     $expo->soft_close;
7799     return $expo->exitstatus();
7800 }
7801
7802 #-> CPAN::Distribution::_validate_distropref
7803 sub _validate_distropref {
7804     my($self,@args) = @_;
7805     if (
7806         $CPAN::META->has_inst("CPAN::Kwalify")
7807         &&
7808         $CPAN::META->has_inst("Kwalify")
7809        ) {
7810         eval {CPAN::Kwalify::_validate("distroprefs",@args);};
7811         if ($@) {
7812             $CPAN::Frontend->mywarn($@);
7813         }
7814     } else {
7815         CPAN->debug("not validating '@args'") if $CPAN::DEBUG;
7816     }
7817 }
7818
7819 #-> CPAN::Distribution::_find_prefs
7820 sub _find_prefs {
7821     my($self) = @_;
7822     my $distroid = $self->pretty_id;
7823     #CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG;
7824     my $prefs_dir = $CPAN::Config->{prefs_dir};
7825     eval { File::Path::mkpath($prefs_dir); };
7826     if ($@) {
7827         $CPAN::Frontend->mydie("Cannot create directory $prefs_dir");
7828     }
7829     my $yaml_module = CPAN::_yaml_module;
7830     my @extensions;
7831     if ($CPAN::META->has_inst($yaml_module)) {
7832         push @extensions, "yml";
7833     } else {
7834         my @fallbacks;
7835         if ($CPAN::META->has_inst("Data::Dumper")) {
7836             push @extensions, "dd";
7837             push @fallbacks, "Data::Dumper";
7838         }
7839         if ($CPAN::META->has_inst("Storable")) {
7840             push @extensions, "st";
7841             push @fallbacks, "Storable";
7842         }
7843         if (@fallbacks) {
7844             local $" = " and ";
7845             unless ($self->{have_complained_about_missing_yaml}++) {
7846                 $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back ".
7847                                         "to @fallbacks to read prefs '$prefs_dir'\n");
7848             }
7849         } else {
7850             unless ($self->{have_complained_about_missing_yaml}++) {
7851                 $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot ".
7852                                         "read prefs '$prefs_dir'\n");
7853             }
7854         }
7855     }
7856     if (@extensions) {
7857         my $dh = DirHandle->new($prefs_dir)
7858             or die Carp::croak("Couldn't open '$prefs_dir': $!");
7859       DIRENT: for (sort $dh->read) {
7860             next if $_ eq "." || $_ eq "..";
7861             my $exte = join "|", @extensions;
7862             next unless /\.($exte)$/;
7863             my $thisexte = $1;
7864             my $abs = File::Spec->catfile($prefs_dir, $_);
7865             if (-f $abs) {
7866                 #CPAN->debug(sprintf "abs[%s]", $abs) if $CPAN::DEBUG;
7867                 my @distropref;
7868                 if ($thisexte eq "yml") {
7869                     # need no eval because if we have no YAML we do not try to read *.yml
7870                     #CPAN->debug(sprintf "before yaml load abs[%s]", $abs) if $CPAN::DEBUG;
7871                     @distropref = @{CPAN->_yaml_loadfile($abs)};
7872                     #CPAN->debug(sprintf "after yaml load abs[%s]", $abs) if $CPAN::DEBUG;
7873                 } elsif ($thisexte eq "dd") {
7874                     package CPAN::Eval;
7875                     no strict;
7876                     open FH, "<$abs" or $CPAN::Frontend->mydie("Could not open '$abs': $!");
7877                     local $/;
7878                     my $eval = <FH>;
7879                     close FH;
7880                     eval $eval;
7881                     if ($@) {
7882                         $CPAN::Frontend->mydie("Error in distroprefs file $_\: $@");
7883                     }
7884                     my $i = 1;
7885                     while (${"VAR".$i}) {
7886                         push @distropref, ${"VAR".$i};
7887                         $i++;
7888                     }
7889                 } elsif ($thisexte eq "st") {
7890                     # eval because Storable is never forward compatible
7891                     eval { @distropref = @{scalar Storable::retrieve($abs)}; };
7892                     if ($@) {
7893                         $CPAN::Frontend->mywarn("Error reading distroprefs file ".
7894                                                 "$_, skipping\: $@");
7895                         $CPAN::Frontend->mysleep(4);
7896                         next DIRENT;
7897                     }
7898                 }
7899                 # $DB::single=1;
7900                 #CPAN->debug(sprintf "#distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
7901               ELEMENT: for my $y (0..$#distropref) {
7902                     my $distropref = $distropref[$y];
7903                     $self->_validate_distropref($distropref,$abs,$y);
7904                     my $match = $distropref->{match};
7905                     unless ($match) {
7906                         #CPAN->debug("no 'match' in abs[$abs], skipping") if $CPAN::DEBUG;
7907                         next ELEMENT;
7908                     }
7909                     my $ok = 1;
7910                     # do not take the order of C<keys %$match> because
7911                     # "module" is by far the slowest
7912                     my $saw_valid_subkeys = 0;
7913                     for my $sub_attribute (qw(distribution perl perlconfig module)) {
7914                         next unless exists $match->{$sub_attribute};
7915                         $saw_valid_subkeys++;
7916                         my $qr = eval "qr{$distropref->{match}{$sub_attribute}}";
7917                         if ($sub_attribute eq "module") {
7918                             my $okm = 0;
7919                             #CPAN->debug(sprintf "distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
7920                             my @modules = $self->containsmods;
7921                             #CPAN->debug(sprintf "modules[%s]", join(",",@modules)) if $CPAN::DEBUG;
7922                           MODULE: for my $module (@modules) {
7923                                 $okm ||= $module =~ /$qr/;
7924                                 last MODULE if $okm;
7925                             }
7926                             $ok &&= $okm;
7927                         } elsif ($sub_attribute eq "distribution") {
7928                             my $okd = $distroid =~ /$qr/;
7929                             $ok &&= $okd;
7930                         } elsif ($sub_attribute eq "perl") {
7931                             my $okp = $^X =~ /$qr/;
7932                             $ok &&= $okp;
7933                         } elsif ($sub_attribute eq "perlconfig") {
7934                             for my $perlconfigkey (keys %{$match->{perlconfig}}) {
7935                                 my $perlconfigval = $match->{perlconfig}->{$perlconfigkey};
7936                                 # XXX should probably warn if Config does not exist
7937                                 my $okpc = $Config::Config{$perlconfigkey} =~ /$perlconfigval/;
7938                                 $ok &&= $okpc;
7939                                 last if $ok == 0;
7940                             }
7941                         } else {
7942                             $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ".
7943                                                    "unknown sub_attribut '$sub_attribute'. ".
7944                                                    "Please ".
7945                                                    "remove, cannot continue.");
7946                         }
7947                         last if $ok == 0; # short circuit
7948                     }
7949                     unless ($saw_valid_subkeys) {
7950                         $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ".
7951                                                "missing match/* subattribute. ".
7952                                                "Please ".
7953                                                "remove, cannot continue.");
7954                     }
7955                     #CPAN->debug(sprintf "ok[%d]", $ok) if $CPAN::DEBUG;
7956                     if ($ok) {
7957                         return {
7958                                 prefs => $distropref,
7959                                 prefs_file => $abs,
7960                                 prefs_file_doc => $y,
7961                                };
7962                     }
7963
7964                 }
7965             }
7966         }
7967         $dh->close;
7968     }
7969     return;
7970 }
7971
7972 # CPAN::Distribution::prefs
7973 sub prefs {
7974     my($self) = @_;
7975     if (exists $self->{negative_prefs_cache}
7976         &&
7977         $self->{negative_prefs_cache} != $CPAN::CurrentCommandId
7978        ) {
7979         delete $self->{negative_prefs_cache};
7980         delete $self->{prefs};
7981     }
7982     if (exists $self->{prefs}) {
7983         return $self->{prefs}; # XXX comment out during debugging
7984     }
7985     if ($CPAN::Config->{prefs_dir}) {
7986         CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG;
7987         my $prefs = $self->_find_prefs();
7988         $prefs ||= ""; # avoid warning next line
7989         CPAN->debug("prefs[$prefs]") if $CPAN::DEBUG;
7990         if ($prefs) {
7991             for my $x (qw(prefs prefs_file prefs_file_doc)) {
7992                 $self->{$x} = $prefs->{$x};
7993             }
7994             my $bs = sprintf(
7995                              "%s[%s]",
7996                              File::Basename::basename($self->{prefs_file}),
7997                              $self->{prefs_file_doc},
7998                             );
7999             my $filler1 = "_" x 22;
8000             my $filler2 = int(66 - length($bs))/2;
8001             $filler2 = 0 if $filler2 < 0;
8002             $filler2 = " " x $filler2;
8003             $CPAN::Frontend->myprint("
8004 $filler1 D i s t r o P r e f s $filler1
8005 $filler2 $bs $filler2
8006 ");
8007             $CPAN::Frontend->mysleep(1);
8008             return $self->{prefs};
8009         }
8010     }
8011     $self->{negative_prefs_cache} = $CPAN::CurrentCommandId;
8012     return $self->{prefs} = +{};
8013 }
8014
8015 # CPAN::Distribution::make_x_arg
8016 sub make_x_arg {
8017     my($self, $whixh) = @_;
8018     my $make_x_arg;
8019     my $prefs = $self->prefs;
8020     if (
8021         $prefs
8022         && exists $prefs->{$whixh}
8023         && exists $prefs->{$whixh}{args}
8024         && $prefs->{$whixh}{args}
8025        ) {
8026         $make_x_arg = join(" ",
8027                            map {CPAN::HandleConfig
8028                                  ->safe_quote($_)} @{$prefs->{$whixh}{args}},
8029                           );
8030     }
8031     my $what = sprintf "make%s_arg", $whixh eq "make" ? "" : $whixh;
8032     $make_x_arg ||= $CPAN::Config->{$what};
8033     return $make_x_arg;
8034 }
8035
8036 # CPAN::Distribution::_make_command
8037 sub _make_command {
8038     my ($self) = @_;
8039     if ($self) {
8040         return
8041             CPAN::HandleConfig
8042                 ->safe_quote(
8043                              CPAN::HandleConfig->prefs_lookup($self,
8044                                                               q{make})
8045                              || $Config::Config{make}
8046                              || 'make'
8047                             );
8048     } else {
8049         # Old style call, without object. Deprecated
8050         Carp::confess("CPAN::_make_command() used as function. Don't Do That.");
8051         return
8052           safe_quote(undef,
8053                      CPAN::HandleConfig->prefs_lookup($self,q{make})
8054                      || $CPAN::Config->{make}
8055                      || $Config::Config{make}
8056                      || 'make');
8057     }
8058 }
8059
8060 #-> sub CPAN::Distribution::follow_prereqs ;
8061 sub follow_prereqs {
8062     my($self) = shift;
8063     my($slot) = shift;
8064     my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
8065     return unless @prereq_tuples;
8066     my @prereq = map { $_->[0] } @prereq_tuples;
8067     my $pretty_id = $self->pretty_id;
8068     my %map = (
8069                b => "build_requires",
8070                r => "requires",
8071                c => "commandline",
8072               );
8073     my($filler1,$filler2,$filler3,$filler4);
8074     # $DB::single=1;
8075     my $unsat = "Unsatisfied dependencies detected during";
8076     my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id);
8077     {
8078         my $r = int(($w - length($unsat))/2);
8079         my $l = $w - length($unsat) - $r;
8080         $filler1 = "-"x4 . " "x$l;
8081         $filler2 = " "x$r . "-"x4 . "\n";
8082     }
8083     {
8084         my $r = int(($w - length($pretty_id))/2);
8085         my $l = $w - length($pretty_id) - $r;
8086         $filler3 = "-"x4 . " "x$l;
8087         $filler4 = " "x$r . "-"x4 . "\n";
8088     }
8089     $CPAN::Frontend->
8090         myprint("$filler1 $unsat $filler2".
8091                 "$filler3 $pretty_id $filler4".
8092                 join("", map {"    $_->[0] \[$map{$_->[1]}]\n"} @prereq_tuples),
8093                );
8094     my $follow = 0;
8095     if ($CPAN::Config->{prerequisites_policy} eq "follow") {
8096         $follow = 1;
8097     } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
8098         my $answer = CPAN::Shell::colorable_makemaker_prompt(
8099 "Shall I follow them and prepend them to the queue
8100 of modules we are processing right now?", "yes");
8101         $follow = $answer =~ /^\s*y/i;
8102     } else {
8103         local($") = ", ";
8104         $CPAN::Frontend->
8105             myprint("  Ignoring dependencies on modules @prereq\n");
8106     }
8107     if ($follow) {
8108         my $id = $self->id;
8109         # color them as dirty
8110         for my $p (@prereq) {
8111             # warn "calling color_cmd_tmps(0,1)";
8112             my $any = CPAN::Shell->expandany($p);
8113             $self->{$slot . "_for"}{$any->id}++;
8114             if ($any) {
8115                 $any->color_cmd_tmps(0,2);
8116             } else {
8117                 $CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$p'\n");
8118                 $CPAN::Frontend->mysleep(2);
8119             }
8120         }
8121         # queue them and re-queue yourself
8122         CPAN::Queue->jumpqueue({qmod => $id, reqtype => $self->{reqtype}},
8123                                map {+{qmod=>$_->[0],reqtype=>$_->[1]}} reverse @prereq_tuples);
8124         $self->{$slot} = "Delayed until after prerequisites";
8125         return 1; # signal success to the queuerunner
8126     }
8127     return;
8128 }
8129
8130 #-> sub CPAN::Distribution::unsat_prereq ;
8131 # return ([Foo=>1],[Bar=>1.2]) for normal modules
8132 # return ([perl=>5.008]) if we need a newer perl than we are running under
8133 sub unsat_prereq {
8134     my($self,$slot) = @_;
8135     my(%merged,$prereq_pm);
8136     my $prefs_depends = $self->prefs->{depends}||{};
8137     if ($slot eq "configure_requires_later") {
8138         my $meta_yml = $self->parse_meta_yml();
8139         %merged = (%{$meta_yml->{configure_requires}||{}},
8140                    %{$prefs_depends->{configure_requires}||{}});
8141         $prereq_pm = {}; # configure_requires defined as "b"
8142     } elsif ($slot eq "later") {
8143         my $prereq_pm_0 = $self->prereq_pm || {};
8144         for my $reqtype (qw(requires build_requires)) {
8145             $prereq_pm->{$reqtype} = {%{$prereq_pm_0->{$reqtype}||{}}}; # copy to not pollute it
8146             for my $k (keys %{$prefs_depends->{$reqtype}||{}}) {
8147                 $prereq_pm->{$reqtype}{$k} = $prefs_depends->{$reqtype}{$k};
8148             }
8149         }
8150         %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}});
8151     } else {
8152         die "Panic: illegal slot '$slot'";
8153     }
8154     my(@need);
8155     my @merged = %merged;
8156     CPAN->debug("all merged_prereqs[@merged]") if $CPAN::DEBUG;
8157   NEED: while (my($need_module, $need_version) = each %merged) {
8158         my($available_version,$available_file,$nmo);
8159         if ($need_module eq "perl") {
8160             $available_version = $];
8161             $available_file = $^X;
8162         } else {
8163             $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
8164             next if $nmo->uptodate;
8165             $available_file = $nmo->available_file;
8166
8167             # if they have not specified a version, we accept any installed one
8168             if (defined $available_file
8169                 and ( # a few quick shortcurcuits
8170                      not defined $need_version
8171                      or $need_version eq '0'    # "==" would trigger warning when not numeric
8172                      or $need_version eq "undef"
8173                     )) {
8174                 next NEED;
8175             }
8176
8177             $available_version = $nmo->available_version;
8178         }
8179
8180         # We only want to install prereqs if either they're not installed
8181         # or if the installed version is too old. We cannot omit this
8182         # check, because if 'force' is in effect, nobody else will check.
8183         if (defined $available_file) {
8184             my(@all_requirements) = split /\s*,\s*/, $need_version;
8185             local($^W) = 0;
8186             my $ok = 0;
8187           RQ: for my $rq (@all_requirements) {
8188                 if ($rq =~ s|>=\s*||) {
8189                 } elsif ($rq =~ s|>\s*||) {
8190                     # 2005-12: one user
8191                     if (CPAN::Version->vgt($available_version,$rq)) {
8192                         $ok++;
8193                     }
8194                     next RQ;
8195                 } elsif ($rq =~ s|!=\s*||) {
8196                     # 2005-12: no user
8197                     if (CPAN::Version->vcmp($available_version,$rq)) {
8198                         $ok++;
8199                         next RQ;
8200                     } else {
8201                         last RQ;
8202                     }
8203                 } elsif ($rq =~ m|<=?\s*|) {
8204                     # 2005-12: no user
8205                     $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n");
8206                     $ok++;
8207                     next RQ;
8208                 }
8209                 if (! CPAN::Version->vgt($rq, $available_version)) {
8210                     $ok++;
8211                 }
8212                 CPAN->debug(sprintf("need_module[%s]available_file[%s]".
8213                                     "available_version[%s]rq[%s]ok[%d]",
8214                                     $need_module,
8215                                     $available_file,
8216                                     $available_version,
8217                                     CPAN::Version->readable($rq),
8218                                     $ok,
8219                                    )) if $CPAN::DEBUG;
8220             }
8221             next NEED if $ok == @all_requirements;
8222         }
8223
8224         if ($need_module eq "perl") {
8225             return ["perl", $need_version];
8226         }
8227         $self->{sponsored_mods}{$need_module} ||= 0;
8228         CPAN->debug("need_module[$need_module]s/s/n[$self->{sponsored_mods}{$need_module}]") if $CPAN::DEBUG;
8229         if ($self->{sponsored_mods}{$need_module}++) {
8230             # We have already sponsored it and for some reason it's still
8231             # not available. So we do ... what??
8232
8233             # if we push it again, we have a potential infinite loop
8234
8235             # The following "next" was a very problematic construct.
8236             # It helped a lot but broke some day and had to be
8237             # replaced.
8238
8239             # We must be able to deal with modules that come again and
8240             # again as a prereq and have themselves prereqs and the
8241             # queue becomes long but finally we would find the correct
8242             # order. The RecursiveDependency check should trigger a
8243             # die when it's becoming too weird. Unfortunately removing
8244             # this next breaks many other things.
8245
8246             # The bug that brought this up is described in Todo under
8247             # "5.8.9 cannot install Compress::Zlib"
8248
8249             # next; # this is the next that had to go away
8250
8251             # The following "next NEED" are fine and the error message
8252             # explains well what is going on. For example when the DBI
8253             # fails and consequently DBD::SQLite fails and now we are
8254             # processing CPAN::SQLite. Then we must have a "next" for
8255             # DBD::SQLite. How can we get it and how can we identify
8256             # all other cases we must identify?
8257
8258             my $do = $nmo->distribution;
8259             next NEED unless $do; # not on CPAN
8260           NOSAYER: for my $nosayer (
8261                                     "unwrapped",
8262                                     "writemakefile",
8263                                     "signature_verify",
8264                                     "make",
8265                                     "make_test",
8266                                     "install",
8267                                     "make_clean",
8268                                    ) {
8269                 if ($do->{$nosayer}) {
8270                     if (UNIVERSAL::can($do->{$nosayer},"failed") ?
8271                         $do->{$nosayer}->failed :
8272                         $do->{$nosayer} =~ /^NO/) {
8273                         if ($nosayer eq "make_test"
8274                             &&
8275                             $do->{make_test}{COMMANDID} != $CPAN::CurrentCommandId
8276                            ) {
8277                             next NOSAYER;
8278                         }
8279                         $CPAN::Frontend->mywarn("Warning: Prerequisite ".
8280                                                 "'$need_module => $need_version' ".
8281                                                 "for '$self->{ID}' failed when ".
8282                                                 "processing '$do->{ID}' with ".
8283                                                 "'$nosayer => $do->{$nosayer}'. Continuing, ".
8284                                                 "but chances to succeed are limited.\n"
8285                                                );
8286                         next NEED;
8287                     } else { # the other guy succeeded
8288                         if ($nosayer eq "install") {
8289                             # we had this with
8290                             # DMAKI/DateTime-Calendar-Chinese-0.05.tar.gz
8291                             # 2007-03
8292                             $CPAN::Frontend->mywarn("Warning: Prerequisite ".
8293                                                     "'$need_module => $need_version' ".
8294                                                     "for '$self->{ID}' already installed ".
8295                                                     "but installation looks suspicious. ".
8296                                                     "Skipping another installation attempt, ".
8297                                                     "to prevent looping endlessly.\n"
8298                                                    );
8299                             next NEED;
8300                         }
8301                     }
8302                 }
8303             }
8304         }
8305         my $needed_as = exists $prereq_pm->{requires}{$need_module} ? "r" : "b";
8306         push @need, [$need_module,$needed_as];
8307     }
8308     my @unfolded = map { "[".join(",",@$_)."]" } @need;
8309     CPAN->debug("returning from unsat_prereq[@unfolded]") if $CPAN::DEBUG;
8310     @need;
8311 }
8312
8313 #-> sub CPAN::Distribution::read_yaml ;
8314 sub read_yaml {
8315     my($self) = @_;
8316     return $self->{yaml_content} if exists $self->{yaml_content};
8317     my $build_dir = $self->{build_dir};
8318     my $yaml = File::Spec->catfile($build_dir,"META.yml");
8319     $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
8320     return unless -f $yaml;
8321     eval { $self->{yaml_content} = CPAN->_yaml_loadfile($yaml)->[0]; };
8322     if ($@) {
8323         $CPAN::Frontend->mywarn("Could not read ".
8324                                 "'$yaml'. Falling back to other ".
8325                                 "methods to determine prerequisites\n");
8326         return $self->{yaml_content} = undef; # if we die, then we
8327                                               # cannot read YAML's own
8328                                               # META.yml
8329     }
8330     # not "authoritative"
8331     if (not exists $self->{yaml_content}{dynamic_config}
8332         or $self->{yaml_content}{dynamic_config}
8333        ) {
8334         $self->{yaml_content} = undef;
8335     }
8336     $self->debug(sprintf "yaml_content[%s]", $self->{yaml_content} || "UNDEF")
8337         if $CPAN::DEBUG;
8338     return $self->{yaml_content};
8339 }
8340
8341 #-> sub CPAN::Distribution::prereq_pm ;
8342 sub prereq_pm {
8343     my($self) = @_;
8344     $self->{prereq_pm_detected} ||= 0;
8345     CPAN->debug("ID[$self->{ID}]prereq_pm_detected[$self->{prereq_pm_detected}]") if $CPAN::DEBUG;
8346     return $self->{prereq_pm} if $self->{prereq_pm_detected};
8347     return unless $self->{writemakefile}  # no need to have succeeded
8348                                           # but we must have run it
8349         || $self->{modulebuild};
8350     CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
8351                 $self->{writemakefile}||"",
8352                 $self->{modulebuild}||"",
8353                ) if $CPAN::DEBUG;
8354     my($req,$breq);
8355     if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
8356         $req =  $yaml->{requires} || {};
8357         $breq =  $yaml->{build_requires} || {};
8358         undef $req unless ref $req eq "HASH" && %$req;
8359         if ($req) {
8360             if ($yaml->{generated_by} &&
8361                 $yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
8362                 my $eummv = do { local $^W = 0; $1+0; };
8363                 if ($eummv < 6.2501) {
8364                     # thanks to Slaven for digging that out: MM before
8365                     # that could be wrong because it could reflect a
8366                     # previous release
8367                     undef $req;
8368                 }
8369             }
8370             my $areq;
8371             my $do_replace;
8372             while (my($k,$v) = each %{$req||{}}) {
8373                 if ($v =~ /\d/) {
8374                     $areq->{$k} = $v;
8375                 } elsif ($k =~ /[A-Za-z]/ &&
8376                          $v =~ /[A-Za-z]/ &&
8377                          $CPAN::META->exists("Module",$v)
8378                         ) {
8379                     $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
8380                                             "requires hash: $k => $v; I'll take both ".
8381                                             "key and value as a module name\n");
8382                     $CPAN::Frontend->mysleep(1);
8383                     $areq->{$k} = 0;
8384                     $areq->{$v} = 0;
8385                     $do_replace++;
8386                 }
8387             }
8388             $req = $areq if $do_replace;
8389         }
8390     }
8391     unless ($req || $breq) {
8392         my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
8393         my $makefile = File::Spec->catfile($build_dir,"Makefile");
8394         my $fh;
8395         if (-f $makefile
8396             and
8397             $fh = FileHandle->new("<$makefile\0")) {
8398             CPAN->debug("Getting prereq from Makefile") if $CPAN::DEBUG;
8399             local($/) = "\n";
8400             while (<$fh>) {
8401                 last if /MakeMaker post_initialize section/;
8402                 my($p) = m{^[\#]
8403                            \s+PREREQ_PM\s+=>\s+(.+)
8404                        }x;
8405                 next unless $p;
8406                 # warn "Found prereq expr[$p]";
8407
8408                 #  Regexp modified by A.Speer to remember actual version of file
8409                 #  PREREQ_PM hash key wants, then add to
8410                 while ( $p =~ m/(?:\s)([\w\:]+)=>(q\[.*?\]|undef),?/g ) {
8411                     # In case a prereq is mentioned twice, complain.
8412                     if ( defined $req->{$1} ) {
8413                         warn "Warning: PREREQ_PM mentions $1 more than once, ".
8414                             "last mention wins";
8415                     }
8416                     my($m,$n) = ($1,$2);
8417                     if ($n =~ /^q\[(.*?)\]$/) {
8418                         $n = $1;
8419                     }
8420                     $req->{$m} = $n;
8421                 }
8422                 last;
8423             }
8424         }
8425     }
8426     unless ($req || $breq) {
8427         my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
8428         my $buildfile = File::Spec->catfile($build_dir,"Build");
8429         if (-f $buildfile) {
8430             CPAN->debug("Found '$buildfile'") if $CPAN::DEBUG;
8431             my $build_prereqs = File::Spec->catfile($build_dir,"_build","prereqs");
8432             if (-f $build_prereqs) {
8433                 CPAN->debug("Getting prerequisites from '$build_prereqs'") if $CPAN::DEBUG;
8434                 my $content = do { local *FH;
8435                                    open FH, $build_prereqs
8436                                        or $CPAN::Frontend->mydie("Could not open ".
8437                                                                  "'$build_prereqs': $!");
8438                                    local $/;
8439                                    <FH>;
8440                                };
8441                 my $bphash = eval $content;
8442                 if ($@) {
8443                 } else {
8444                     $req  = $bphash->{requires} || +{};
8445                     $breq = $bphash->{build_requires} || +{};
8446                 }
8447             }
8448         }
8449     }
8450     if (-f "Build.PL"
8451         && ! -f "Makefile.PL"
8452         && ! exists $req->{"Module::Build"}
8453         && ! $CPAN::META->has_inst("Module::Build")) {
8454         $CPAN::Frontend->mywarn("  Warning: CPAN.pm discovered Module::Build as ".
8455                                 "undeclared prerequisite.\n".
8456                                 "  Adding it now as such.\n"
8457                                );
8458         $CPAN::Frontend->mysleep(5);
8459         $req->{"Module::Build"} = 0;
8460         delete $self->{writemakefile};
8461     }
8462     if ($req || $breq) {
8463         $self->{prereq_pm_detected}++;
8464         return $self->{prereq_pm} = { requires => $req, build_requires => $breq };
8465     }
8466 }
8467
8468 #-> sub CPAN::Distribution::test ;
8469 sub test {
8470     my($self) = @_;
8471     if (my $goto = $self->prefs->{goto}) {
8472         return $self->goto($goto);
8473     }
8474     $self->make;
8475     if ($CPAN::Signal) {
8476       delete $self->{force_update};
8477       return;
8478     }
8479     # warn "XDEBUG: checking for notest: $self->{notest} $self";
8480     if ($self->{notest}) {
8481         $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
8482         return 1;
8483     }
8484
8485     my $make = $self->{modulebuild} ? "Build" : "make";
8486
8487     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
8488                            ? $ENV{PERL5LIB}
8489                            : ($ENV{PERLLIB} || "");
8490
8491     $CPAN::META->set_perl5lib;
8492     local $ENV{MAKEFLAGS}; # protect us from outer make calls
8493
8494     $CPAN::Frontend->myprint("Running $make test\n");
8495
8496   EXCUSE: {
8497         my @e;
8498         if ($self->{make} or $self->{later}) {
8499             # go ahead
8500         } else {
8501             push @e,
8502                 "Make had some problems, won't test";
8503         }
8504
8505         exists $self->{make} and
8506             (
8507              UNIVERSAL::can($self->{make},"failed") ?
8508              $self->{make}->failed :
8509              $self->{make} =~ /^NO/
8510             ) and push @e, "Can't test without successful make";
8511         $self->{badtestcnt} ||= 0;
8512         if ($self->{badtestcnt} > 0) {
8513             require Data::Dumper;
8514             CPAN->debug(sprintf "NOREPEAT[%s]", Data::Dumper::Dumper($self)) if $CPAN::DEBUG;
8515             push @e, "Won't repeat unsuccessful test during this command";
8516         }
8517
8518         push @e, $self->{later} if $self->{later};
8519         push @e, $self->{configure_requires_later} if $self->{configure_requires_later};
8520
8521         if (exists $self->{build_dir}) {
8522             if (exists $self->{make_test}) {
8523                 if (
8524                     UNIVERSAL::can($self->{make_test},"failed") ?
8525                     $self->{make_test}->failed :
8526                     $self->{make_test} =~ /^NO/
8527                    ) {
8528                     if (
8529                         UNIVERSAL::can($self->{make_test},"commandid")
8530                         &&
8531                         $self->{make_test}->commandid == $CPAN::CurrentCommandId
8532                        ) {
8533                         push @e, "Has already been tested within this command";
8534                     }
8535                 } else {
8536                     push @e, "Has already been tested successfully";
8537                 }
8538             }
8539         } elsif (!@e) {
8540             push @e, "Has no own directory";
8541         }
8542         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
8543         unless (chdir $self->{build_dir}) {
8544             push @e, "Couldn't chdir to '$self->{build_dir}': $!";
8545         }
8546         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
8547     }
8548     $self->debug("Changed directory to $self->{build_dir}")
8549         if $CPAN::DEBUG;
8550
8551     if ($^O eq 'MacOS') {
8552         Mac::BuildTools::make_test($self);
8553         return;
8554     }
8555
8556     if ($self->{modulebuild}) {
8557         my $v = CPAN::Shell->expand("Module","Test::Harness")->inst_version;
8558         if (CPAN::Version->vlt($v,2.62)) {
8559             $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
8560   '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n});
8561             $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old");
8562             return;
8563         }
8564     }
8565
8566     my $system;
8567     my $prefs_test = $self->prefs->{test};
8568     if (my $commandline
8569         = exists $prefs_test->{commandline} ? $prefs_test->{commandline} : "") {
8570         $system = $commandline;
8571         $ENV{PERL} = $^X;
8572     } elsif ($self->{modulebuild}) {
8573         $system = sprintf "%s test", $self->_build_command();
8574     } else {
8575         $system = join " ", $self->_make_command(), "test";
8576     }
8577     my $make_test_arg = $self->make_x_arg("test");
8578     $system = sprintf("%s%s",
8579                       $system,
8580                       $make_test_arg ? " $make_test_arg" : "",
8581                      );
8582     my($tests_ok);
8583     my %env;
8584     while (my($k,$v) = each %ENV) {
8585         next unless defined $v;
8586         $env{$k} = $v;
8587     }
8588     local %ENV = %env;
8589     if (my $env = $self->prefs->{test}{env}) {
8590         for my $e (keys %$env) {
8591             $ENV{$e} = $env->{$e};
8592         }
8593     }
8594     my $expect_model = $self->_prefs_with_expect("test");
8595     my $want_expect = 0;
8596     if ( $expect_model && @{$expect_model->{talk}} ) {
8597         my $can_expect = $CPAN::META->has_inst("Expect");
8598         if ($can_expect) {
8599             $want_expect = 1;
8600         } else {
8601             $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
8602                                     "testing without\n");
8603         }
8604     }
8605     if ($want_expect) {
8606         if ($self->_should_report('test')) {
8607             $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ".
8608                                     "not supported when distroprefs specify ".
8609                                     "an interactive test\n");
8610         }
8611         $tests_ok = $self->_run_via_expect($system,$expect_model) == 0;
8612     } elsif ( $self->_should_report('test') ) {
8613         $tests_ok = CPAN::Reporter::test($self, $system);
8614     } else {
8615         $tests_ok = system($system) == 0;
8616     }
8617     $self->introduce_myself;
8618     if ( $tests_ok ) {
8619         {
8620             my @prereq;
8621
8622             # local $CPAN::DEBUG = 16; # Distribution
8623             for my $m (keys %{$self->{sponsored_mods}}) {
8624                 next unless $self->{sponsored_mods}{$m} > 0;
8625                 my $m_obj = CPAN::Shell->expand("Module",$m) or next;
8626                 # XXX we need available_version which reflects
8627                 # $ENV{PERL5LIB} so that already tested but not yet
8628                 # installed modules are counted.
8629                 my $available_version = $m_obj->available_version;
8630                 my $available_file = $m_obj->available_file;
8631                 if ($available_version &&
8632                     !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m})
8633                    ) {
8634                     CPAN->debug("m[$m] good enough available_version[$available_version]")
8635                         if $CPAN::DEBUG;
8636                 } elsif ($available_file
8637                          && (
8638                              !$self->{prereq_pm}{$m}
8639                              ||
8640                              $self->{prereq_pm}{$m} == 0
8641                             )
8642                         ) {
8643                     # lex Class::Accessor::Chained::Fast which has no $VERSION
8644                     CPAN->debug("m[$m] have available_file[$available_file]")
8645                         if $CPAN::DEBUG;
8646                 } else {
8647                     push @prereq, $m;
8648                 }
8649             }
8650             if (@prereq) {
8651                 my $cnt = @prereq;
8652                 my $which = join ",", @prereq;
8653                 my $but = $cnt == 1 ? "one dependency not OK ($which)" :
8654                     "$cnt dependencies missing ($which)";
8655                 $CPAN::Frontend->mywarn("Tests succeeded but $but\n");
8656                 $self->{make_test} = CPAN::Distrostatus->new("NO $but");
8657                 $self->store_persistent_state;
8658                 return $self->goodbye("[dependencies] -- NA");
8659             }
8660         }
8661
8662         $CPAN::Frontend->myprint("  $system -- OK\n");
8663         $self->{make_test} = CPAN::Distrostatus->new("YES");
8664         $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
8665         # probably impossible to need the next line because badtestcnt
8666         # has a lifespan of one command
8667         delete $self->{badtestcnt};
8668     } else {
8669         $self->{make_test} = CPAN::Distrostatus->new("NO");
8670         $self->{badtestcnt}++;
8671         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
8672         CPAN::Shell->optprint("hint",sprintf "//hint// To get more information about failing tests, try:
8673   reports %s\n", $self->pretty_id);
8674     }
8675     $self->store_persistent_state;
8676 }
8677
8678 sub _prefs_with_expect {
8679     my($self,$where) = @_;
8680     return unless my $prefs = $self->prefs;
8681     return unless my $where_prefs = $prefs->{$where};
8682     if ($where_prefs->{expect}) {
8683         return {
8684                 mode => "deterministic",
8685                 timeout => 15,
8686                 talk => $where_prefs->{expect},
8687                };
8688     } elsif ($where_prefs->{"eexpect"}) {
8689         return $where_prefs->{"eexpect"};
8690     }
8691     return;
8692 }
8693
8694 #-> sub CPAN::Distribution::clean ;
8695 sub clean {
8696     my($self) = @_;
8697     my $make = $self->{modulebuild} ? "Build" : "make";
8698     $CPAN::Frontend->myprint("Running $make clean\n");
8699     unless (exists $self->{archived}) {
8700         $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped".
8701                                 "/untarred, nothing done\n");
8702         return 1;
8703     }
8704     unless (exists $self->{build_dir}) {
8705         $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
8706         return 1;
8707     }
8708     if (exists $self->{writemakefile}
8709         and $self->{writemakefile}->failed
8710        ) {
8711         $CPAN::Frontend->mywarn("No Makefile, don't know how to 'make clean'\n");
8712         return 1;
8713     }
8714   EXCUSE: {
8715         my @e;
8716         exists $self->{make_clean} and $self->{make_clean} eq "YES" and
8717             push @e, "make clean already called once";
8718         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
8719     }
8720     chdir $self->{build_dir} or
8721         Carp::confess("Couldn't chdir to $self->{build_dir}: $!");
8722     $self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG;
8723
8724     if ($^O eq 'MacOS') {
8725         Mac::BuildTools::make_clean($self);
8726         return;
8727     }
8728
8729     my $system;
8730     if ($self->{modulebuild}) {
8731         unless (-f "Build") {
8732             my $cwd = CPAN::anycwd();
8733             $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
8734                                     " in cwd[$cwd]. Danger, Will Robinson!");
8735             $CPAN::Frontend->mysleep(5);
8736         }
8737         $system = sprintf "%s clean", $self->_build_command();
8738     } else {
8739         $system  = join " ", $self->_make_command(), "clean";
8740     }
8741     my $system_ok = system($system) == 0;
8742     $self->introduce_myself;
8743     if ( $system_ok ) {
8744       $CPAN::Frontend->myprint("  $system -- OK\n");
8745
8746       # $self->force;
8747
8748       # Jost Krieger pointed out that this "force" was wrong because
8749       # it has the effect that the next "install" on this distribution
8750       # will untar everything again. Instead we should bring the
8751       # object's state back to where it is after untarring.
8752
8753       for my $k (qw(
8754                     force_update
8755                     install
8756                     writemakefile
8757                     make
8758                     make_test
8759                    )) {
8760           delete $self->{$k};
8761       }
8762       $self->{make_clean} = CPAN::Distrostatus->new("YES");
8763
8764     } else {
8765       # Hmmm, what to do if make clean failed?
8766
8767       $self->{make_clean} = CPAN::Distrostatus->new("NO");
8768       $CPAN::Frontend->mywarn(qq{  $system -- NOT OK\n});
8769
8770       # 2006-02-27: seems silly to me to force a make now
8771       # $self->force("make"); # so that this directory won't be used again
8772
8773     }
8774     $self->store_persistent_state;
8775 }
8776
8777 #-> sub CPAN::Distribution::goto ;
8778 sub goto {
8779     my($self,$goto) = @_;
8780     $goto = $self->normalize($goto);
8781     my $why = sprintf(
8782                       "Goto '$goto' via prefs file '%s' doc %d",
8783                       $self->{prefs_file},
8784                       $self->{prefs_file_doc},
8785                      );
8786     $self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
8787     # 2007-07-16 akoenig : Better than NA would be if we could inherit
8788     # the status of the $goto distro but given the exceptional nature
8789     # of 'goto' I feel reluctant to implement it
8790     my $goodbye_message = "[goto] -- NA $why";
8791     $self->goodbye($goodbye_message);
8792
8793     # inject into the queue
8794
8795     CPAN::Queue->delete($self->id);
8796     CPAN::Queue->jumpqueue({qmod => $goto, reqtype => $self->{reqtype}});
8797
8798     # and run where we left off
8799
8800     my($method) = (caller(1))[3];
8801     CPAN->instance("CPAN::Distribution",$goto)->$method();
8802     CPAN::Queue->delete_first($goto);
8803 }
8804
8805 #-> sub CPAN::Distribution::install ;
8806 sub install {
8807     my($self) = @_;
8808     if (my $goto = $self->prefs->{goto}) {
8809         return $self->goto($goto);
8810     }
8811     # $DB::single=1;
8812     unless ($self->{badtestcnt}) {
8813         $self->test;
8814     }
8815     if ($CPAN::Signal) {
8816       delete $self->{force_update};
8817       return;
8818     }
8819     my $make = $self->{modulebuild} ? "Build" : "make";
8820     $CPAN::Frontend->myprint("Running $make install\n");
8821   EXCUSE: {
8822         my @e;
8823         if ($self->{make} or $self->{later}) {
8824             # go ahead
8825         } else {
8826             push @e,
8827                 "Make had some problems, won't install";
8828         }
8829
8830         exists $self->{make} and
8831             (
8832              UNIVERSAL::can($self->{make},"failed") ?
8833              $self->{make}->failed :
8834              $self->{make} =~ /^NO/
8835             ) and
8836             push @e, "Make had returned bad status, install seems impossible";
8837
8838         if (exists $self->{build_dir}) {
8839         } elsif (!@e) {
8840             push @e, "Has no own directory";
8841         }
8842
8843         if (exists $self->{make_test} and
8844             (
8845              UNIVERSAL::can($self->{make_test},"failed") ?
8846              $self->{make_test}->failed :
8847              $self->{make_test} =~ /^NO/
8848             )) {
8849             if ($self->{force_update}) {
8850                 $self->{make_test}->text("FAILED but failure ignored because ".
8851                                          "'force' in effect");
8852             } else {
8853                 push @e, "make test had returned bad status, ".
8854                     "won't install without force"
8855             }
8856         }
8857         if (exists $self->{install}) {
8858             if (UNIVERSAL::can($self->{install},"text") ?
8859                 $self->{install}->text eq "YES" :
8860                 $self->{install} =~ /^YES/
8861                ) {
8862                 $CPAN::Frontend->myprint("  Already done\n");
8863                 $CPAN::META->is_installed($self->{build_dir});
8864                 return 1;
8865             } else {
8866                 # comment in Todo on 2006-02-11; maybe retry?
8867                 push @e, "Already tried without success";
8868             }
8869         }
8870
8871         push @e, $self->{later} if $self->{later};
8872         push @e, $self->{configure_requires_later} if $self->{configure_requires_later};
8873
8874         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
8875         unless (chdir $self->{build_dir}) {
8876             push @e, "Couldn't chdir to '$self->{build_dir}': $!";
8877         }
8878         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
8879     }
8880     $self->debug("Changed directory to $self->{build_dir}")
8881         if $CPAN::DEBUG;
8882
8883     if ($^O eq 'MacOS') {
8884         Mac::BuildTools::make_install($self);
8885         return;
8886     }
8887
8888     my $system;
8889     if (my $commandline = $self->prefs->{install}{commandline}) {
8890         $system = $commandline;
8891         $ENV{PERL} = $^X;
8892     } elsif ($self->{modulebuild}) {
8893         my($mbuild_install_build_command) =
8894             exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
8895                 $CPAN::Config->{mbuild_install_build_command} ?
8896                     $CPAN::Config->{mbuild_install_build_command} :
8897                         $self->_build_command();
8898         $system = sprintf("%s install %s",
8899                           $mbuild_install_build_command,
8900                           $CPAN::Config->{mbuild_install_arg},
8901                          );
8902     } else {
8903         my($make_install_make_command) =
8904             CPAN::HandleConfig->prefs_lookup($self,
8905                                              q{make_install_make_command})
8906                   || $self->_make_command();
8907         $system = sprintf("%s install %s",
8908                           $make_install_make_command,
8909                           $CPAN::Config->{make_install_arg},
8910                          );
8911     }
8912
8913     my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 ";
8914     my $brip = CPAN::HandleConfig->prefs_lookup($self,
8915                                                 q{build_requires_install_policy});
8916     $brip ||="ask/yes";
8917     my $id = $self->id;
8918     my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command
8919     my $want_install = "yes";
8920     if ($reqtype eq "b") {
8921         if ($brip eq "no") {
8922             $want_install = "no";
8923         } elsif ($brip =~ m|^ask/(.+)|) {
8924             my $default = $1;
8925             $default = "yes" unless $default =~ /^(y|n)/i;
8926             $want_install =
8927                 CPAN::Shell::colorable_makemaker_prompt
8928                       ("$id is just needed temporarily during building or testing. ".
8929                        "Do you want to install it permanently? (Y/n)",
8930                        $default);
8931         }
8932     }
8933     unless ($want_install =~ /^y/i) {
8934         my $is_only = "is only 'build_requires'";
8935         $CPAN::Frontend->mywarn("Not installing because $is_only\n");
8936         $self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
8937         delete $self->{force_update};
8938         return;
8939     }
8940     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
8941                            ? $ENV{PERL5LIB}
8942                            : ($ENV{PERLLIB} || "");
8943
8944     $CPAN::META->set_perl5lib;
8945     my($pipe) = FileHandle->new("$system $stderr |");
8946     my($makeout) = "";
8947     while (<$pipe>) {
8948         print $_; # intentionally NOT use Frontend->myprint because it
8949                   # looks irritating when we markup in color what we
8950                   # just pass through from an external program
8951         $makeout .= $_;
8952     }
8953     $pipe->close;
8954     my $close_ok = $? == 0;
8955     $self->introduce_myself;
8956     if ( $close_ok ) {
8957         $CPAN::Frontend->myprint("  $system -- OK\n");
8958         $CPAN::META->is_installed($self->{build_dir});
8959         $self->{install} = CPAN::Distrostatus->new("YES");
8960     } else {
8961         $self->{install} = CPAN::Distrostatus->new("NO");
8962         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
8963         my $mimc =
8964             CPAN::HandleConfig->prefs_lookup($self,
8965                                              q{make_install_make_command});
8966         if (
8967             $makeout =~ /permission/s
8968             && $> > 0
8969             && (
8970                 ! $mimc
8971                 || $mimc eq (CPAN::HandleConfig->prefs_lookup($self,
8972                                                               q{make}))
8973                )
8974            ) {
8975             $CPAN::Frontend->myprint(
8976                                      qq{----\n}.
8977                                      qq{  You may have to su }.
8978                                      qq{to root to install the package\n}.
8979                                      qq{  (Or you may want to run something like\n}.
8980                                      qq{    o conf make_install_make_command 'sudo make'\n}.
8981                                      qq{  to raise your permissions.}
8982                                     );
8983         }
8984     }
8985     delete $self->{force_update};
8986     # $DB::single = 1;
8987     $self->store_persistent_state;
8988 }
8989
8990 sub introduce_myself {
8991     my($self) = @_;
8992     $CPAN::Frontend->myprint(sprintf("  %s\n",$self->pretty_id));
8993 }
8994
8995 #-> sub CPAN::Distribution::dir ;
8996 sub dir {
8997     shift->{build_dir};
8998 }
8999
9000 #-> sub CPAN::Distribution::perldoc ;
9001 sub perldoc {
9002     my($self) = @_;
9003
9004     my($dist) = $self->id;
9005     my $package = $self->called_for;
9006
9007     $self->_display_url( $CPAN::Defaultdocs . $package );
9008 }
9009
9010 #-> sub CPAN::Distribution::_check_binary ;
9011 sub _check_binary {
9012     my ($dist,$shell,$binary) = @_;
9013     my ($pid,$out);
9014
9015     $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
9016       if $CPAN::DEBUG;
9017
9018     if ($CPAN::META->has_inst("File::Which")) {
9019         return File::Which::which($binary);
9020     } else {
9021         local *README;
9022         $pid = open README, "which $binary|"
9023             or $CPAN::Frontend->mywarn(qq{Could not fork 'which $binary': $!\n});
9024         return unless $pid;
9025         while (<README>) {
9026             $out .= $_;
9027         }
9028         close README
9029             or $CPAN::Frontend->mywarn("Could not run 'which $binary': $!\n")
9030                 and return;
9031     }
9032
9033     $CPAN::Frontend->myprint(qq{   + $out \n})
9034       if $CPAN::DEBUG && $out;
9035
9036     return $out;
9037 }
9038
9039 #-> sub CPAN::Distribution::_display_url ;
9040 sub _display_url {
9041     my($self,$url) = @_;
9042     my($res,$saved_file,$pid,$out);
9043
9044     $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
9045       if $CPAN::DEBUG;
9046
9047     # should we define it in the config instead?
9048     my $html_converter = "html2text.pl";
9049
9050     my $web_browser = $CPAN::Config->{'lynx'} || undef;
9051     my $web_browser_out = $web_browser
9052         ? CPAN::Distribution->_check_binary($self,$web_browser)
9053         : undef;
9054
9055     if ($web_browser_out) {
9056         # web browser found, run the action
9057         my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
9058         $CPAN::Frontend->myprint(qq{system[$browser $url]})
9059             if $CPAN::DEBUG;
9060         $CPAN::Frontend->myprint(qq{
9061 Displaying URL
9062   $url
9063 with browser $browser
9064 });
9065         $CPAN::Frontend->mysleep(1);
9066         system("$browser $url");
9067         if ($saved_file) { 1 while unlink($saved_file) }
9068     } else {
9069         # web browser not found, let's try text only
9070         my $html_converter_out =
9071             CPAN::Distribution->_check_binary($self,$html_converter);
9072         $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out);
9073
9074         if ($html_converter_out ) {
9075             # html2text found, run it
9076             $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
9077             $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n})
9078                 unless defined($saved_file);
9079
9080             local *README;
9081             $pid = open README, "$html_converter $saved_file |"
9082                 or $CPAN::Frontend->mydie(qq{
9083 Could not fork '$html_converter $saved_file': $!});
9084             my($fh,$filename);
9085             if ($CPAN::META->has_inst("File::Temp")) {
9086                 $fh = File::Temp->new(
9087                                       dir      => File::Spec->tmpdir,
9088                                       template => 'cpan_htmlconvert_XXXX',
9089                                       suffix => '.txt',
9090                                       unlink => 0,
9091                                      );
9092                 $filename = $fh->filename;
9093             } else {
9094                 $filename = "cpan_htmlconvert_$$.txt";
9095                 $fh = FileHandle->new();
9096                 open $fh, ">$filename" or die;
9097             }
9098             while (<README>) {
9099                 $fh->print($_);
9100             }
9101             close README or
9102                 $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
9103             my $tmpin = $fh->filename;
9104             $CPAN::Frontend->myprint(sprintf(qq{
9105 Run '%s %s' and
9106 saved output to %s\n},
9107                                              $html_converter,
9108                                              $saved_file,
9109                                              $tmpin,
9110                                             )) if $CPAN::DEBUG;
9111             close $fh;
9112             local *FH;
9113             open FH, $tmpin
9114                 or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
9115             my $fh_pager = FileHandle->new;
9116             local($SIG{PIPE}) = "IGNORE";
9117             my $pager = $CPAN::Config->{'pager'} || "cat";
9118             $fh_pager->open("|$pager")
9119                 or $CPAN::Frontend->mydie(qq{
9120 Could not open pager '$pager': $!});
9121             $CPAN::Frontend->myprint(qq{
9122 Displaying URL
9123   $url
9124 with pager "$pager"
9125 });
9126             $CPAN::Frontend->mysleep(1);
9127             $fh_pager->print(<FH>);
9128             $fh_pager->close;
9129         } else {
9130             # coldn't find the web browser or html converter
9131             $CPAN::Frontend->myprint(qq{
9132 You need to install lynx or $html_converter to use this feature.});
9133         }
9134     }
9135 }
9136
9137 #-> sub CPAN::Distribution::_getsave_url ;
9138 sub _getsave_url {
9139     my($dist, $shell, $url) = @_;
9140
9141     $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
9142       if $CPAN::DEBUG;
9143
9144     my($fh,$filename);
9145     if ($CPAN::META->has_inst("File::Temp")) {
9146         $fh = File::Temp->new(
9147                               dir      => File::Spec->tmpdir,
9148                               template => "cpan_getsave_url_XXXX",
9149                               suffix => ".html",
9150                               unlink => 0,
9151                              );
9152         $filename = $fh->filename;
9153     } else {
9154         $fh = FileHandle->new;
9155         $filename = "cpan_getsave_url_$$.html";
9156     }
9157     my $tmpin = $filename;
9158     if ($CPAN::META->has_usable('LWP')) {
9159         $CPAN::Frontend->myprint("Fetching with LWP:
9160   $url
9161 ");
9162         my $Ua;
9163         CPAN::LWP::UserAgent->config;
9164         eval { $Ua = CPAN::LWP::UserAgent->new; };
9165         if ($@) {
9166             $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
9167             return;
9168         } else {
9169             my($var);
9170             $Ua->proxy('http', $var)
9171                 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
9172             $Ua->no_proxy($var)
9173                 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
9174         }
9175
9176         my $req = HTTP::Request->new(GET => $url);
9177         $req->header('Accept' => 'text/html');
9178         my $res = $Ua->request($req);
9179         if ($res->is_success) {
9180             $CPAN::Frontend->myprint(" + request successful.\n")
9181                 if $CPAN::DEBUG;
9182             print $fh $res->content;
9183             close $fh;
9184             $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
9185                 if $CPAN::DEBUG;
9186             return $tmpin;
9187         } else {
9188             $CPAN::Frontend->myprint(sprintf(
9189                                              "LWP failed with code[%s], message[%s]\n",
9190                                              $res->code,
9191                                              $res->message,
9192                                             ));
9193             return;
9194         }
9195     } else {
9196         $CPAN::Frontend->mywarn("  LWP not available\n");
9197         return;
9198     }
9199 }
9200
9201 #-> sub CPAN::Distribution::_build_command
9202 sub _build_command {
9203     my($self) = @_;
9204     if ($^O eq "MSWin32") { # special code needed at least up to
9205                             # Module::Build 0.2611 and 0.2706; a fix
9206                             # in M:B has been promised 2006-01-30
9207         my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
9208         return "$perl ./Build";
9209     }
9210     return "./Build";
9211 }
9212
9213 #-> sub CPAN::Distribution::_should_report
9214 sub _should_report {
9215     my($self, $phase) = @_;
9216     die "_should_report() requires a 'phase' argument"
9217         if ! defined $phase;
9218
9219     # configured
9220     my $test_report = CPAN::HandleConfig->prefs_lookup($self,
9221                                                        q{test_report});
9222     return unless $test_report;
9223
9224     # don't repeat if we cached a result
9225     return $self->{should_report}
9226         if exists $self->{should_report};
9227
9228     # available
9229     if ( ! $CPAN::META->has_inst("CPAN::Reporter")) {
9230         $CPAN::Frontend->mywarn(
9231             "CPAN::Reporter not installed.  No reports will be sent.\n"
9232         );
9233         return $self->{should_report} = 0;
9234     }
9235
9236     # capable
9237     my $crv = CPAN::Reporter->VERSION;
9238     if ( CPAN::Version->vlt( $crv, 0.99 ) ) {
9239         # don't cache $self->{should_report} -- need to check each phase
9240         if ( $phase eq 'test' ) {
9241             return 1;
9242         }
9243         else {
9244             $CPAN::Frontend->mywarn(
9245                 "Reporting on the '$phase' phase requires CPAN::Reporter 0.99, but \n" .
9246                 "you only have version $crv\.  Only 'test' phase reports will be sent.\n"
9247             );
9248             return;
9249         }
9250     }
9251
9252     # appropriate
9253     if ($self->is_dot_dist) {
9254         $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
9255                                 "for local directories\n");
9256         return $self->{should_report} = 0;
9257     }
9258     if ($self->prefs->{patches}
9259         &&
9260         @{$self->prefs->{patches}}
9261         &&
9262         $self->{patched}
9263        ) {
9264         $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
9265                                 "when the source has been patched\n");
9266         return $self->{should_report} = 0;
9267     }
9268
9269     # proceed and cache success
9270     return $self->{should_report} = 1;
9271 }
9272
9273 #-> sub CPAN::Distribution::reports
9274 sub reports {
9275     my($self) = @_;
9276     my $pathname = $self->id;
9277     $CPAN::Frontend->myprint("Distribution: $pathname\n");
9278
9279     unless ($CPAN::META->has_inst("CPAN::DistnameInfo")) {
9280         $CPAN::Frontend->mydie("CPAN::DistnameInfo not installed; cannot continue");
9281     }
9282     unless ($CPAN::META->has_usable("LWP")) {
9283         $CPAN::Frontend->mydie("LWP not installed; cannot continue");
9284     }
9285     unless ($CPAN::META->has_inst("File::Temp")) {
9286         $CPAN::Frontend->mydie("File::Temp not installed; cannot continue");
9287     }
9288
9289     my $d = CPAN::DistnameInfo->new($pathname);
9290
9291     my $dist      = $d->dist;      # "CPAN-DistnameInfo"
9292     my $version   = $d->version;   # "0.02"
9293     my $maturity  = $d->maturity;  # "released"
9294     my $filename  = $d->filename;  # "CPAN-DistnameInfo-0.02.tar.gz"
9295     my $cpanid    = $d->cpanid;    # "GBARR"
9296     my $distvname = $d->distvname; # "CPAN-DistnameInfo-0.02"
9297
9298     my $url = sprintf "http://cpantesters.perl.org/show/%s.yaml", $dist;
9299
9300     CPAN::LWP::UserAgent->config;
9301     my $Ua;
9302     eval { $Ua = CPAN::LWP::UserAgent->new; };
9303     if ($@) {
9304         $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
9305     }
9306     $CPAN::Frontend->myprint("Fetching '$url'...");
9307     my $resp = $Ua->get($url);
9308     unless ($resp->is_success) {
9309         $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
9310     }
9311     $CPAN::Frontend->myprint("DONE\n\n");
9312     my $yaml = $resp->content;
9313     # was fuer ein Umweg!
9314     my $fh = File::Temp->new(
9315                              dir      => File::Spec->tmpdir,
9316                              template => 'cpan_reports_XXXX',
9317                              suffix => '.yaml',
9318                              unlink => 0,
9319                             );
9320     my $tfilename = $fh->filename;
9321     print $fh $yaml;
9322     close $fh or $CPAN::Frontend->mydie("Could not close '$tfilename': $!");
9323     my $unserialized = CPAN->_yaml_loadfile($tfilename)->[0];
9324     unlink $tfilename or $CPAN::Frontend->mydie("Could not unlink '$tfilename': $!");
9325     my %other_versions;
9326     my $this_version_seen;
9327     for my $rep (@$unserialized) {
9328         my $rversion = $rep->{version};
9329         if ($rversion eq $version) {
9330             unless ($this_version_seen++) {
9331                 $CPAN::Frontend->myprint ("$rep->{version}:\n");
9332             }
9333             $CPAN::Frontend->myprint
9334                 (sprintf("%1s%1s%-4s %s on %s %s (%s)\n",
9335                          $rep->{archname} eq $Config::Config{archname}?"*":"",
9336                          $rep->{action}eq"PASS"?"+":$rep->{action}eq"FAIL"?"-":"",
9337                          $rep->{action},
9338                          $rep->{perl},
9339                          ucfirst $rep->{osname},
9340                          $rep->{osvers},
9341                          $rep->{archname},
9342                         ));
9343         } else {
9344             $other_versions{$rep->{version}}++;
9345         }
9346     }
9347     unless ($this_version_seen) {
9348         $CPAN::Frontend->myprint("No reports found for version '$version'
9349 Reports for other versions:\n");
9350         for my $v (sort keys %other_versions) {
9351             $CPAN::Frontend->myprint(" $v\: $other_versions{$v}\n");
9352         }
9353     }
9354     $url =~ s/\.yaml/.html/;
9355     $CPAN::Frontend->myprint("See $url for details\n");
9356 }
9357
9358 package CPAN::Bundle;
9359 use strict;
9360
9361 sub look {
9362     my $self = shift;
9363     $CPAN::Frontend->myprint($self->as_string);
9364 }
9365
9366 #-> CPAN::Bundle::undelay
9367 sub undelay {
9368     my $self = shift;
9369     delete $self->{later};
9370     for my $c ( $self->contains ) {
9371         my $obj = CPAN::Shell->expandany($c) or next;
9372         $obj->undelay;
9373     }
9374 }
9375
9376 # mark as dirty/clean
9377 #-> sub CPAN::Bundle::color_cmd_tmps ;
9378 sub color_cmd_tmps {
9379     my($self) = shift;
9380     my($depth) = shift || 0;
9381     my($color) = shift || 0;
9382     my($ancestors) = shift || [];
9383     # a module needs to recurse to its cpan_file, a distribution needs
9384     # to recurse into its prereq_pms, a bundle needs to recurse into its modules
9385
9386     return if exists $self->{incommandcolor}
9387         && $color==1
9388         && $self->{incommandcolor}==$color;
9389     if ($depth>=$CPAN::MAX_RECURSION) {
9390         die(CPAN::Exception::RecursiveDependency->new($ancestors));
9391     }
9392     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
9393
9394     for my $c ( $self->contains ) {
9395         my $obj = CPAN::Shell->expandany($c) or next;
9396         CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
9397         $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
9398     }
9399     # never reached code?
9400     #if ($color==0) {
9401       #delete $self->{badtestcnt};
9402     #}
9403     $self->{incommandcolor} = $color;
9404 }
9405
9406 #-> sub CPAN::Bundle::as_string ;
9407 sub as_string {
9408     my($self) = @_;
9409     $self->contains;
9410     # following line must be "=", not "||=" because we have a moving target
9411     $self->{INST_VERSION} = $self->inst_version;
9412     return $self->SUPER::as_string;
9413 }
9414
9415 #-> sub CPAN::Bundle::contains ;
9416 sub contains {
9417     my($self) = @_;
9418     my($inst_file) = $self->inst_file || "";
9419     my($id) = $self->id;
9420     $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
9421     if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) {
9422         undef $inst_file;
9423     }
9424     unless ($inst_file) {
9425         # Try to get at it in the cpan directory
9426         $self->debug("no inst_file") if $CPAN::DEBUG;
9427         my $cpan_file;
9428         $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
9429               $cpan_file = $self->cpan_file;
9430         if ($cpan_file eq "N/A") {
9431             $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
9432   Maybe stale symlink? Maybe removed during session? Giving up.\n");
9433         }
9434         my $dist = $CPAN::META->instance('CPAN::Distribution',
9435                                          $self->cpan_file);
9436         $self->debug("before get id[$dist->{ID}]") if $CPAN::DEBUG;
9437         $dist->get;
9438         $self->debug("after get id[$dist->{ID}]") if $CPAN::DEBUG;
9439         my($todir) = $CPAN::Config->{'cpan_home'};
9440         my(@me,$from,$to,$me);
9441         @me = split /::/, $self->id;
9442         $me[-1] .= ".pm";
9443         $me = File::Spec->catfile(@me);
9444         $from = $self->find_bundle_file($dist->{build_dir},join('/',@me));
9445         $to = File::Spec->catfile($todir,$me);
9446         File::Path::mkpath(File::Basename::dirname($to));
9447         File::Copy::copy($from, $to)
9448               or Carp::confess("Couldn't copy $from to $to: $!");
9449         $inst_file = $to;
9450     }
9451     my @result;
9452     my $fh = FileHandle->new;
9453     local $/ = "\n";
9454     open($fh,$inst_file) or die "Could not open '$inst_file': $!";
9455     my $in_cont = 0;
9456     $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
9457     while (<$fh>) {
9458         $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
9459             m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
9460         next unless $in_cont;
9461         next if /^=/;
9462         s/\#.*//;
9463         next if /^\s+$/;
9464         chomp;
9465         push @result, (split " ", $_, 2)[0];
9466     }
9467     close $fh;
9468     delete $self->{STATUS};
9469     $self->{CONTAINS} = \@result;
9470     $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
9471     unless (@result) {
9472         $CPAN::Frontend->mywarn(qq{
9473 The bundle file "$inst_file" may be a broken
9474 bundlefile. It seems not to contain any bundle definition.
9475 Please check the file and if it is bogus, please delete it.
9476 Sorry for the inconvenience.
9477 });
9478     }
9479     @result;
9480 }
9481
9482 #-> sub CPAN::Bundle::find_bundle_file
9483 # $where is in local format, $what is in unix format
9484 sub find_bundle_file {
9485     my($self,$where,$what) = @_;
9486     $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
9487 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
9488 ###    my $bu = File::Spec->catfile($where,$what);
9489 ###    return $bu if -f $bu;
9490     my $manifest = File::Spec->catfile($where,"MANIFEST");
9491     unless (-f $manifest) {
9492         require ExtUtils::Manifest;
9493         my $cwd = CPAN::anycwd();
9494         $self->safe_chdir($where);
9495         ExtUtils::Manifest::mkmanifest();
9496         $self->safe_chdir($cwd);
9497     }
9498     my $fh = FileHandle->new($manifest)
9499         or Carp::croak("Couldn't open $manifest: $!");
9500     local($/) = "\n";
9501     my $bundle_filename = $what;
9502     $bundle_filename =~ s|Bundle.*/||;
9503     my $bundle_unixpath;
9504     while (<$fh>) {
9505         next if /^\s*\#/;
9506         my($file) = /(\S+)/;
9507         if ($file =~ m|\Q$what\E$|) {
9508             $bundle_unixpath = $file;
9509             # return File::Spec->catfile($where,$bundle_unixpath); # bad
9510             last;
9511         }
9512         # retry if she managed to have no Bundle directory
9513         $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
9514     }
9515     return File::Spec->catfile($where, split /\//, $bundle_unixpath)
9516         if $bundle_unixpath;
9517     Carp::croak("Couldn't find a Bundle file in $where");
9518 }
9519
9520 # needs to work quite differently from Module::inst_file because of
9521 # cpan_home/Bundle/ directory and the possibility that we have
9522 # shadowing effect. As it makes no sense to take the first in @INC for
9523 # Bundles, we parse them all for $VERSION and take the newest.
9524
9525 #-> sub CPAN::Bundle::inst_file ;
9526 sub inst_file {
9527     my($self) = @_;
9528     my($inst_file);
9529     my(@me);
9530     @me = split /::/, $self->id;
9531     $me[-1] .= ".pm";
9532     my($incdir,$bestv);
9533     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
9534         my $bfile = File::Spec->catfile($incdir, @me);
9535         CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
9536         next unless -f $bfile;
9537         my $foundv = MM->parse_version($bfile);
9538         if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
9539             $self->{INST_FILE} = $bfile;
9540             $self->{INST_VERSION} = $bestv = $foundv;
9541         }
9542     }
9543     $self->{INST_FILE};
9544 }
9545
9546 #-> sub CPAN::Bundle::inst_version ;
9547 sub inst_version {
9548     my($self) = @_;
9549     $self->inst_file; # finds INST_VERSION as side effect
9550     $self->{INST_VERSION};
9551 }
9552
9553 #-> sub CPAN::Bundle::rematein ;
9554 sub rematein {
9555     my($self,$meth) = @_;
9556     $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
9557     my($id) = $self->id;
9558     Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
9559         unless $self->inst_file || $self->cpan_file;
9560     my($s,%fail);
9561     for $s ($self->contains) {
9562         my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
9563             $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
9564         if ($type eq 'CPAN::Distribution') {
9565             $CPAN::Frontend->mywarn(qq{
9566 The Bundle }.$self->id.qq{ contains
9567 explicitly a file '$s'.
9568 Going to $meth that.
9569 });
9570             $CPAN::Frontend->mysleep(5);
9571         }
9572         # possibly noisy action:
9573         $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
9574         my $obj = $CPAN::META->instance($type,$s);
9575         $obj->{reqtype} = $self->{reqtype};
9576         $obj->$meth();
9577     }
9578 }
9579
9580 # If a bundle contains another that contains an xs_file we have here,
9581 # we just don't bother I suppose
9582 #-> sub CPAN::Bundle::xs_file
9583 sub xs_file {
9584     return 0;
9585 }
9586
9587 #-> sub CPAN::Bundle::force ;
9588 sub fforce   { shift->rematein('fforce',@_); }
9589 #-> sub CPAN::Bundle::force ;
9590 sub force   { shift->rematein('force',@_); }
9591 #-> sub CPAN::Bundle::notest ;
9592 sub notest  { shift->rematein('notest',@_); }
9593 #-> sub CPAN::Bundle::get ;
9594 sub get     { shift->rematein('get',@_); }
9595 #-> sub CPAN::Bundle::make ;
9596 sub make    { shift->rematein('make',@_); }
9597 #-> sub CPAN::Bundle::test ;
9598 sub test    {
9599     my $self = shift;
9600     # $self->{badtestcnt} ||= 0;
9601     $self->rematein('test',@_);
9602 }
9603 #-> sub CPAN::Bundle::install ;
9604 sub install {
9605   my $self = shift;
9606   $self->rematein('install',@_);
9607 }
9608 #-> sub CPAN::Bundle::clean ;
9609 sub clean   { shift->rematein('clean',@_); }
9610
9611 #-> sub CPAN::Bundle::uptodate ;
9612 sub uptodate {
9613     my($self) = @_;
9614     return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
9615     my $c;
9616     foreach $c ($self->contains) {
9617         my $obj = CPAN::Shell->expandany($c);
9618         return 0 unless $obj->uptodate;
9619     }
9620     return 1;
9621 }
9622
9623 #-> sub CPAN::Bundle::readme ;
9624 sub readme  {
9625     my($self) = @_;
9626     my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
9627 No File found for bundle } . $self->id . qq{\n}), return;
9628     $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
9629     $CPAN::META->instance('CPAN::Distribution',$file)->readme;
9630 }
9631
9632 package CPAN::Module;
9633 use strict;
9634
9635 # Accessors
9636 #-> sub CPAN::Module::userid
9637 sub userid {
9638     my $self = shift;
9639     my $ro = $self->ro;
9640     return unless $ro;
9641     return $ro->{userid} || $ro->{CPAN_USERID};
9642 }
9643 #-> sub CPAN::Module::description
9644 sub description {
9645     my $self = shift;
9646     my $ro = $self->ro or return "";
9647     $ro->{description}
9648 }
9649
9650 #-> sub CPAN::Module::distribution
9651 sub distribution {
9652     my($self) = @_;
9653     CPAN::Shell->expand("Distribution",$self->cpan_file);
9654 }
9655
9656 #-> sub CPAN::Module::undelay
9657 sub undelay {
9658     my $self = shift;
9659     delete $self->{later};
9660     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
9661         $dist->undelay;
9662     }
9663 }
9664
9665 # mark as dirty/clean
9666 #-> sub CPAN::Module::color_cmd_tmps ;
9667 sub color_cmd_tmps {
9668     my($self) = shift;
9669     my($depth) = shift || 0;
9670     my($color) = shift || 0;
9671     my($ancestors) = shift || [];
9672     # a module needs to recurse to its cpan_file
9673
9674     return if exists $self->{incommandcolor}
9675         && $color==1
9676         && $self->{incommandcolor}==$color;
9677     return if $color==0 && !$self->{incommandcolor};
9678     if ($color>=1) {
9679         if ( $self->uptodate ) {
9680             $self->{incommandcolor} = $color;
9681             return;
9682         } elsif (my $have_version = $self->available_version) {
9683             # maybe what we have is good enough
9684             if (@$ancestors) {
9685                 my $who_asked_for_me = $ancestors->[-1];
9686                 my $obj = CPAN::Shell->expandany($who_asked_for_me);
9687                 if (0) {
9688                 } elsif ($obj->isa("CPAN::Bundle")) {
9689                     # bundles cannot specify a minimum version
9690                     return;
9691                 } elsif ($obj->isa("CPAN::Distribution")) {
9692                     if (my $prereq_pm = $obj->prereq_pm) {
9693                         for my $k (keys %$prereq_pm) {
9694                             if (my $want_version = $prereq_pm->{$k}{$self->id}) {
9695                                 if (CPAN::Version->vcmp($have_version,$want_version) >= 0) {
9696                                     $self->{incommandcolor} = $color;
9697                                     return;
9698                                 }
9699                             }
9700                         }
9701                     }
9702                 }
9703             }
9704         }
9705     } else {
9706         $self->{incommandcolor} = $color; # set me before recursion,
9707                                           # so we can break it
9708     }
9709     if ($depth>=$CPAN::MAX_RECURSION) {
9710         die(CPAN::Exception::RecursiveDependency->new($ancestors));
9711     }
9712     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
9713
9714     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
9715         $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
9716     }
9717     # unreached code?
9718     # if ($color==0) {
9719     #    delete $self->{badtestcnt};
9720     # }
9721     $self->{incommandcolor} = $color;
9722 }
9723
9724 #-> sub CPAN::Module::as_glimpse ;
9725 sub as_glimpse {
9726     my($self) = @_;
9727     my(@m);
9728     my $class = ref($self);
9729     $class =~ s/^CPAN:://;
9730     my $color_on = "";
9731     my $color_off = "";
9732     if (
9733         $CPAN::Shell::COLOR_REGISTERED
9734         &&
9735         $CPAN::META->has_inst("Term::ANSIColor")
9736         &&
9737         $self->description
9738        ) {
9739         $color_on = Term::ANSIColor::color("green");
9740         $color_off = Term::ANSIColor::color("reset");
9741     }
9742     my $uptodateness = " ";
9743     if ($class eq "Bundle") {
9744     } elsif ($self->uptodate) {
9745         $uptodateness = "=";
9746     } elsif ($self->inst_version) {
9747         $uptodateness = "<";
9748     }
9749     push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n",
9750                      $class,
9751                      $uptodateness,
9752                      $color_on,
9753                      $self->id,
9754                      $color_off,
9755                      ($self->distribution ?
9756                       $self->distribution->pretty_id :
9757                       $self->cpan_userid
9758                      ),
9759                     );
9760     join "", @m;
9761 }
9762
9763 #-> sub CPAN::Module::dslip_status
9764 sub dslip_status {
9765     my($self) = @_;
9766     my($stat);
9767     # development status
9768     @{$stat->{D}}{qw,i c a b R M S,}     = qw,idea
9769                                               pre-alpha alpha beta released
9770                                               mature standard,;
9771     # support level
9772     @{$stat->{S}}{qw,m d u n a,}         = qw,mailing-list
9773                                               developer comp.lang.perl.*
9774                                               none abandoned,;
9775     # language
9776     @{$stat->{L}}{qw,p c + o h,}         = qw,perl C C++ other hybrid,;
9777     # interface
9778     @{$stat->{I}}{qw,f r O p h n,}       = qw,functions
9779                                               references+ties
9780                                               object-oriented pragma
9781                                               hybrid none,;
9782     # public licence
9783     @{$stat->{P}}{qw,p g l b a 2 o d r n,} = qw,Standard-Perl
9784                                               GPL LGPL
9785                                               BSD Artistic Artistic_2
9786                                               open-source
9787                                               distribution_allowed
9788                                               restricted_distribution
9789                                               no_licence,;
9790     for my $x (qw(d s l i p)) {
9791         $stat->{$x}{' '} = 'unknown';
9792         $stat->{$x}{'?'} = 'unknown';
9793     }
9794     my $ro = $self->ro;
9795     return +{} unless $ro && $ro->{statd};
9796     return {
9797             D  => $ro->{statd},
9798             S  => $ro->{stats},
9799             L  => $ro->{statl},
9800             I  => $ro->{stati},
9801             P  => $ro->{statp},
9802             DV => $stat->{D}{$ro->{statd}},
9803             SV => $stat->{S}{$ro->{stats}},
9804             LV => $stat->{L}{$ro->{statl}},
9805             IV => $stat->{I}{$ro->{stati}},
9806             PV => $stat->{P}{$ro->{statp}},
9807            };
9808 }
9809
9810 #-> sub CPAN::Module::as_string ;
9811 sub as_string {
9812     my($self) = @_;
9813     my(@m);
9814     CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
9815     my $class = ref($self);
9816     $class =~ s/^CPAN:://;
9817     local($^W) = 0;
9818     push @m, $class, " id = $self->{ID}\n";
9819     my $sprintf = "    %-12s %s\n";
9820     push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
9821         if $self->description;
9822     my $sprintf2 = "    %-12s %s (%s)\n";
9823     my($userid);
9824     $userid = $self->userid;
9825     if ( $userid ) {
9826         my $author;
9827         if ($author = CPAN::Shell->expand('Author',$userid)) {
9828             my $email = "";
9829             my $m; # old perls
9830             if ($m = $author->email) {
9831                 $email = " <$m>";
9832             }
9833             push @m, sprintf(
9834                              $sprintf2,
9835                              'CPAN_USERID',
9836                              $userid,
9837                              $author->fullname . $email
9838                             );
9839         }
9840     }
9841     push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
9842         if $self->cpan_version;
9843     if (my $cpan_file = $self->cpan_file) {
9844         push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
9845         if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
9846             my $upload_date = $dist->upload_date;
9847             if ($upload_date) {
9848                 push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
9849             }
9850         }
9851     }
9852     my $sprintf3 = "    %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n";
9853     my $dslip = $self->dslip_status;
9854     push @m, sprintf(
9855                      $sprintf3,
9856                      'DSLIP_STATUS',
9857                      @{$dslip}{qw(D S L I P DV SV LV IV PV)},
9858                     ) if $dslip->{D};
9859     my $local_file = $self->inst_file;
9860     unless ($self->{MANPAGE}) {
9861         my $manpage;
9862         if ($local_file) {
9863             $manpage = $self->manpage_headline($local_file);
9864         } else {
9865             # If we have already untarred it, we should look there
9866             my $dist = $CPAN::META->instance('CPAN::Distribution',
9867                                              $self->cpan_file);
9868             # warn "dist[$dist]";
9869             # mff=manifest file; mfh=manifest handle
9870             my($mff,$mfh);
9871             if (
9872                 $dist->{build_dir}
9873                 and
9874                 (-f  ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
9875                 and
9876                 $mfh = FileHandle->new($mff)
9877                ) {
9878                 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
9879                 my $lfre = $self->id; # local file RE
9880                 $lfre =~ s/::/./g;
9881                 $lfre .= "\\.pm\$";
9882                 my($lfl); # local file file
9883                 local $/ = "\n";
9884                 my(@mflines) = <$mfh>;
9885                 for (@mflines) {
9886                     s/^\s+//;
9887                     s/\s.*//s;
9888                 }
9889                 while (length($lfre)>5 and !$lfl) {
9890                     ($lfl) = grep /$lfre/, @mflines;
9891                     CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
9892                     $lfre =~ s/.+?\.//;
9893                 }
9894                 $lfl =~ s/\s.*//; # remove comments
9895                 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
9896                 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
9897                 # warn "lfl_abs[$lfl_abs]";
9898                 if (-f $lfl_abs) {
9899                     $manpage = $self->manpage_headline($lfl_abs);
9900                 }
9901             }
9902         }
9903         $self->{MANPAGE} = $manpage if $manpage;
9904     }
9905     my($item);
9906     for $item (qw/MANPAGE/) {
9907         push @m, sprintf($sprintf, $item, $self->{$item})
9908             if exists $self->{$item};
9909     }
9910     for $item (qw/CONTAINS/) {
9911         push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
9912             if exists $self->{$item} && @{$self->{$item}};
9913     }
9914     push @m, sprintf($sprintf, 'INST_FILE',
9915                      $local_file || "(not installed)");
9916     push @m, sprintf($sprintf, 'INST_VERSION',
9917                      $self->inst_version) if $local_file;
9918     join "", @m, "\n";
9919 }
9920
9921 #-> sub CPAN::Module::manpage_headline
9922 sub manpage_headline {
9923     my($self,$local_file) = @_;
9924     my(@local_file) = $local_file;
9925     $local_file =~ s/\.pm(?!\n)\Z/.pod/;
9926     push @local_file, $local_file;
9927     my(@result,$locf);
9928     for $locf (@local_file) {
9929         next unless -f $locf;
9930         my $fh = FileHandle->new($locf)
9931             or $Carp::Frontend->mydie("Couldn't open $locf: $!");
9932         my $inpod = 0;
9933         local $/ = "\n";
9934         while (<$fh>) {
9935             $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
9936                 m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
9937             next unless $inpod;
9938             next if /^=/;
9939             next if /^\s+$/;
9940             chomp;
9941             push @result, $_;
9942         }
9943         close $fh;
9944         last if @result;
9945     }
9946     for (@result) {
9947         s/^\s+//;
9948         s/\s+$//;
9949     }
9950     join " ", @result;
9951 }
9952
9953 #-> sub CPAN::Module::cpan_file ;
9954 # Note: also inherited by CPAN::Bundle
9955 sub cpan_file {
9956     my $self = shift;
9957     # CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
9958     unless ($self->ro) {
9959         CPAN::Index->reload;
9960     }
9961     my $ro = $self->ro;
9962     if ($ro && defined $ro->{CPAN_FILE}) {
9963         return $ro->{CPAN_FILE};
9964     } else {
9965         my $userid = $self->userid;
9966         if ( $userid ) {
9967             if ($CPAN::META->exists("CPAN::Author",$userid)) {
9968                 my $author = $CPAN::META->instance("CPAN::Author",
9969                                                    $userid);
9970                 my $fullname = $author->fullname;
9971                 my $email = $author->email;
9972                 unless (defined $fullname && defined $email) {
9973                     return sprintf("Contact Author %s",
9974                                    $userid,
9975                                   );
9976                 }
9977                 return "Contact Author $fullname <$email>";
9978             } else {
9979                 return "Contact Author $userid (Email address not available)";
9980             }
9981         } else {
9982             return "N/A";
9983         }
9984     }
9985 }
9986
9987 #-> sub CPAN::Module::cpan_version ;
9988 sub cpan_version {
9989     my $self = shift;
9990
9991     my $ro = $self->ro;
9992     unless ($ro) {
9993         # Can happen with modules that are not on CPAN
9994         $ro = {};
9995     }
9996     $ro->{CPAN_VERSION} = 'undef'
9997         unless defined $ro->{CPAN_VERSION};
9998     $ro->{CPAN_VERSION};
9999 }
10000
10001 #-> sub CPAN::Module::force ;
10002 sub force {
10003     my($self) = @_;
10004     $self->{force_update} = 1;
10005 }
10006
10007 #-> sub CPAN::Module::fforce ;
10008 sub fforce {
10009     my($self) = @_;
10010     $self->{force_update} = 2;
10011 }
10012
10013 #-> sub CPAN::Module::notest ;
10014 sub notest {
10015     my($self) = @_;
10016     # $CPAN::Frontend->mywarn("XDEBUG: set notest for Module");
10017     $self->{notest}++;
10018 }
10019
10020 #-> sub CPAN::Module::rematein ;
10021 sub rematein {
10022     my($self,$meth) = @_;
10023     $CPAN::Frontend->myprint(sprintf("Running %s for module '%s'\n",
10024                                      $meth,
10025                                      $self->id));
10026     my $cpan_file = $self->cpan_file;
10027     if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/) {
10028         $CPAN::Frontend->mywarn(sprintf qq{
10029   The module %s isn\'t available on CPAN.
10030
10031   Either the module has not yet been uploaded to CPAN, or it is
10032   temporary unavailable. Please contact the author to find out
10033   more about the status. Try 'i %s'.
10034 },
10035                                 $self->id,
10036                                 $self->id,
10037                                );
10038         return;
10039     }
10040     my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
10041     $pack->called_for($self->id);
10042     if (exists $self->{force_update}) {
10043         if ($self->{force_update} == 2) {
10044             $pack->fforce($meth);
10045         } else {
10046             $pack->force($meth);
10047         }
10048     }
10049     $pack->notest($meth) if exists $self->{notest} && $self->{notest};
10050
10051     $pack->{reqtype} ||= "";
10052     CPAN->debug("dist-reqtype[$pack->{reqtype}]".
10053                 "self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG;
10054         if ($pack->{reqtype}) {
10055             if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) {
10056                 $pack->{reqtype} = $self->{reqtype};
10057                 if (
10058                     exists $pack->{install}
10059                     &&
10060                     (
10061                      UNIVERSAL::can($pack->{install},"failed") ?
10062                      $pack->{install}->failed :
10063                      $pack->{install} =~ /^NO/
10064                     )
10065                    ) {
10066                     delete $pack->{install};
10067                     $CPAN::Frontend->mywarn
10068                         ("Promoting $pack->{ID} from 'build_requires' to 'requires'");
10069                 }
10070             }
10071         } else {
10072             $pack->{reqtype} = $self->{reqtype};
10073         }
10074
10075     my $success = eval {
10076         $pack->$meth();
10077     };
10078     my $err = $@;
10079     $pack->unforce if $pack->can("unforce") && exists $self->{force_update};
10080     $pack->unnotest if $pack->can("unnotest") && exists $self->{notest};
10081     delete $self->{force_update};
10082     delete $self->{notest};
10083     if ($err) {
10084         die $err;
10085     }
10086     return $success;
10087 }
10088
10089 #-> sub CPAN::Module::perldoc ;
10090 sub perldoc { shift->rematein('perldoc') }
10091 #-> sub CPAN::Module::readme ;
10092 sub readme  { shift->rematein('readme') }
10093 #-> sub CPAN::Module::look ;
10094 sub look    { shift->rematein('look') }
10095 #-> sub CPAN::Module::cvs_import ;
10096 sub cvs_import { shift->rematein('cvs_import') }
10097 #-> sub CPAN::Module::get ;
10098 sub get     { shift->rematein('get',@_) }
10099 #-> sub CPAN::Module::make ;
10100 sub make    { shift->rematein('make') }
10101 #-> sub CPAN::Module::test ;
10102 sub test   {
10103     my $self = shift;
10104     # $self->{badtestcnt} ||= 0;
10105     $self->rematein('test',@_);
10106 }
10107 #-> sub CPAN::Module::uptodate ;
10108 sub uptodate {
10109     my($self) = @_;
10110     local($_); # protect against a bug in MakeMaker 6.17
10111     my($latest) = $self->cpan_version;
10112     $latest ||= 0;
10113     my($inst_file) = $self->inst_file;
10114     my($have) = 0;
10115     if (defined $inst_file) {
10116         $have = $self->inst_version;
10117     }
10118     local($^W)=0;
10119     if ($inst_file
10120         &&
10121         ! CPAN::Version->vgt($latest, $have)
10122        ) {
10123         CPAN->debug("returning uptodate. inst_file[$inst_file] ".
10124                     "latest[$latest] have[$have]") if $CPAN::DEBUG;
10125         return 1;
10126     }
10127     return;
10128 }
10129 #-> sub CPAN::Module::install ;
10130 sub install {
10131     my($self) = @_;
10132     my($doit) = 0;
10133     if ($self->uptodate
10134         &&
10135         not exists $self->{force_update}
10136        ) {
10137         $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
10138                                          $self->id,
10139                                          $self->inst_version,
10140                                         ));
10141     } else {
10142         $doit = 1;
10143     }
10144     my $ro = $self->ro;
10145     if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
10146         $CPAN::Frontend->mywarn(qq{
10147 \n\n\n     ***WARNING***
10148      The module $self->{ID} has no active maintainer.\n\n\n
10149 });
10150         $CPAN::Frontend->mysleep(5);
10151     }
10152     $self->rematein('install') if $doit;
10153 }
10154 #-> sub CPAN::Module::clean ;
10155 sub clean  { shift->rematein('clean') }
10156
10157 #-> sub CPAN::Module::inst_file ;
10158 sub inst_file {
10159     my($self) = @_;
10160     $self->_file_in_path([@INC]);
10161 }
10162
10163 #-> sub CPAN::Module::available_file ;
10164 sub available_file {
10165     my($self) = @_;
10166     my $sep = $Config::Config{path_sep};
10167     my $perllib = $ENV{PERL5LIB};
10168     $perllib = $ENV{PERLLIB} unless defined $perllib;
10169     my @perllib = split(/$sep/,$perllib) if defined $perllib;
10170     $self->_file_in_path([@perllib,@INC]);
10171 }
10172
10173 #-> sub CPAN::Module::file_in_path ;
10174 sub _file_in_path {
10175     my($self,$path) = @_;
10176     my($dir,@packpath);
10177     @packpath = split /::/, $self->{ID};
10178     $packpath[-1] .= ".pm";
10179     if (@packpath == 1 && $packpath[0] eq "readline.pm") {
10180         unshift @packpath, "Term", "ReadLine"; # historical reasons
10181     }
10182     foreach $dir (@$path) {
10183         my $pmfile = File::Spec->catfile($dir,@packpath);
10184         if (-f $pmfile) {
10185             return $pmfile;
10186         }
10187     }
10188     return;
10189 }
10190
10191 #-> sub CPAN::Module::xs_file ;
10192 sub xs_file {
10193     my($self) = @_;
10194     my($dir,@packpath);
10195     @packpath = split /::/, $self->{ID};
10196     push @packpath, $packpath[-1];
10197     $packpath[-1] .= "." . $Config::Config{'dlext'};
10198     foreach $dir (@INC) {
10199         my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
10200         if (-f $xsfile) {
10201             return $xsfile;
10202         }
10203     }
10204     return;
10205 }
10206
10207 #-> sub CPAN::Module::inst_version ;
10208 sub inst_version {
10209     my($self) = @_;
10210     my $parsefile = $self->inst_file or return;
10211     my $have = $self->parse_version($parsefile);
10212     $have;
10213 }
10214
10215 #-> sub CPAN::Module::inst_version ;
10216 sub available_version {
10217     my($self) = @_;
10218     my $parsefile = $self->available_file or return;
10219     my $have = $self->parse_version($parsefile);
10220     $have;
10221 }
10222
10223 #-> sub CPAN::Module::parse_version ;
10224 sub parse_version {
10225     my($self,$parsefile) = @_;
10226     my $have = MM->parse_version($parsefile);
10227     $have = "undef" unless defined $have && length $have;
10228     $have =~ s/^ //; # since the %vd hack these two lines here are needed
10229     $have =~ s/ $//; # trailing whitespace happens all the time
10230
10231     $have = CPAN::Version->readable($have);
10232
10233     $have =~ s/\s*//g; # stringify to float around floating point issues
10234     $have; # no stringify needed, \s* above matches always
10235 }
10236
10237 #-> sub CPAN::Module::reports
10238 sub reports {
10239     my($self) = @_;
10240     $self->distribution->reports;
10241 }
10242
10243 package CPAN;
10244 use strict;
10245
10246 1;
10247
10248
10249 __END__
10250
10251 =head1 NAME
10252
10253 CPAN - query, download and build perl modules from CPAN sites
10254
10255 =head1 SYNOPSIS
10256
10257 Interactive mode:
10258
10259   perl -MCPAN -e shell
10260
10261 --or--
10262
10263   cpan
10264
10265 Basic commands:
10266
10267   # Modules:
10268
10269   cpan> install Acme::Meta                       # in the shell
10270
10271   CPAN::Shell->install("Acme::Meta");            # in perl
10272
10273   # Distributions:
10274
10275   cpan> install NWCLARK/Acme-Meta-0.02.tar.gz    # in the shell
10276
10277   CPAN::Shell->
10278     install("NWCLARK/Acme-Meta-0.02.tar.gz");    # in perl
10279
10280   # module objects:
10281
10282   $mo = CPAN::Shell->expandany($mod);
10283   $mo = CPAN::Shell->expand("Module",$mod);      # same thing
10284
10285   # distribution objects:
10286
10287   $do = CPAN::Shell->expand("Module",$mod)->distribution;
10288   $do = CPAN::Shell->expandany($distro);         # same thing
10289   $do = CPAN::Shell->expand("Distribution",
10290                             $distro);            # same thing
10291
10292 =head1 DESCRIPTION
10293
10294 The CPAN module automates or at least simplifies the make and install
10295 of perl modules and extensions. It includes some primitive searching
10296 capabilities and knows how to use Net::FTP or LWP or some external
10297 download clients to fetch the distributions from the net.
10298
10299 These are fetched from one or more of the mirrored CPAN (Comprehensive
10300 Perl Archive Network) sites and unpacked in a dedicated directory.
10301
10302 The CPAN module also supports the concept of named and versioned
10303 I<bundles> of modules. Bundles simplify the handling of sets of
10304 related modules. See Bundles below.
10305
10306 The package contains a session manager and a cache manager. The
10307 session manager keeps track of what has been fetched, built and
10308 installed in the current session. The cache manager keeps track of the
10309 disk space occupied by the make processes and deletes excess space
10310 according to a simple FIFO mechanism.
10311
10312 All methods provided are accessible in a programmer style and in an
10313 interactive shell style.
10314
10315 =head2 CPAN::shell([$prompt, $command]) Starting Interactive Mode
10316
10317 The interactive mode is entered by running
10318
10319     perl -MCPAN -e shell
10320
10321 or
10322
10323     cpan
10324
10325 which puts you into a readline interface. If C<Term::ReadKey> and
10326 either C<Term::ReadLine::Perl> or C<Term::ReadLine::Gnu> are installed
10327 it supports both history and command completion.
10328
10329 Once you are on the command line, type C<h> to get a one page help
10330 screen and the rest should be self-explanatory.
10331
10332 The function call C<shell> takes two optional arguments, one is the
10333 prompt, the second is the default initial command line (the latter
10334 only works if a real ReadLine interface module is installed).
10335
10336 The most common uses of the interactive modes are
10337
10338 =over 2
10339
10340 =item Searching for authors, bundles, distribution files and modules
10341
10342 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
10343 for each of the four categories and another, C<i> for any of the
10344 mentioned four. Each of the four entities is implemented as a class
10345 with slightly differing methods for displaying an object.
10346
10347 Arguments you pass to these commands are either strings exactly matching
10348 the identification string of an object or regular expressions that are
10349 then matched case-insensitively against various attributes of the
10350 objects. The parser recognizes a regular expression only if you
10351 enclose it between two slashes.
10352
10353 The principle is that the number of found objects influences how an
10354 item is displayed. If the search finds one item, the result is
10355 displayed with the rather verbose method C<as_string>, but if we find
10356 more than one, we display each object with the terse method
10357 C<as_glimpse>.
10358
10359 =item C<get>, C<make>, C<test>, C<install>, C<clean> modules or distributions
10360
10361 These commands take any number of arguments and investigate what is
10362 necessary to perform the action. If the argument is a distribution
10363 file name (recognized by embedded slashes), it is processed. If it is
10364 a module, CPAN determines the distribution file in which this module
10365 is included and processes that, following any dependencies named in
10366 the module's META.yml or Makefile.PL (this behavior is controlled by
10367 the configuration parameter C<prerequisites_policy>.)
10368
10369 C<get> downloads a distribution file and untars or unzips it, C<make>
10370 builds it, C<test> runs the test suite, and C<install> installs it.
10371
10372 Any C<make> or C<test> are run unconditionally. An
10373
10374   install <distribution_file>
10375
10376 also is run unconditionally. But for
10377
10378   install <module>
10379
10380 CPAN checks if an install is actually needed for it and prints
10381 I<module up to date> in the case that the distribution file containing
10382 the module doesn't need to be updated.
10383
10384 CPAN also keeps track of what it has done within the current session
10385 and doesn't try to build a package a second time regardless if it
10386 succeeded or not. It does not repeat a test run if the test
10387 has been run successfully before. Same for install runs.
10388
10389 The C<force> pragma may precede another command (currently: C<get>,
10390 C<make>, C<test>, or C<install>) and executes the command from scratch
10391 and tries to continue in case of some errors. See the section below on
10392 the C<force> and the C<fforce> pragma.
10393
10394 The C<notest> pragma may be used to skip the test part in the build
10395 process.
10396
10397 Example:
10398
10399     cpan> notest install Tk
10400
10401 A C<clean> command results in a
10402
10403   make clean
10404
10405 being executed within the distribution file's working directory.
10406
10407 =item C<readme>, C<perldoc>, C<look> module or distribution
10408
10409 C<readme> displays the README file of the associated distribution.
10410 C<Look> gets and untars (if not yet done) the distribution file,
10411 changes to the appropriate directory and opens a subshell process in
10412 that directory. C<perldoc> displays the pod documentation of the
10413 module in html or plain text format.
10414
10415 =item C<ls> author
10416
10417 =item C<ls> globbing_expression
10418
10419 The first form lists all distribution files in and below an author's
10420 CPAN directory as they are stored in the CHECKUMS files distributed on
10421 CPAN. The listing goes recursive into all subdirectories.
10422
10423 The second form allows to limit or expand the output with shell
10424 globbing as in the following examples:
10425
10426       ls JV/make*
10427       ls GSAR/*make*
10428       ls */*make*
10429
10430 The last example is very slow and outputs extra progress indicators
10431 that break the alignment of the result.
10432
10433 Note that globbing only lists directories explicitly asked for, for
10434 example FOO/* will not list FOO/bar/Acme-Sthg-n.nn.tar.gz. This may be
10435 regarded as a bug and may be changed in future versions.
10436
10437 =item C<failed>
10438
10439 The C<failed> command reports all distributions that failed on one of
10440 C<make>, C<test> or C<install> for some reason in the currently
10441 running shell session.
10442
10443 =item Persistence between sessions
10444
10445 If the C<YAML> or the c<YAML::Syck> module is installed a record of
10446 the internal state of all modules is written to disk after each step.
10447 The files contain a signature of the currently running perl version
10448 for later perusal.
10449
10450 If the configurations variable C<build_dir_reuse> is set to a true
10451 value, then CPAN.pm reads the collected YAML files. If the stored
10452 signature matches the currently running perl the stored state is
10453 loaded into memory such that effectively persistence between sessions
10454 is established.
10455
10456 =item The C<force> and the C<fforce> pragma
10457
10458 To speed things up in complex installation scenarios, CPAN.pm keeps
10459 track of what it has already done and refuses to do some things a
10460 second time. A C<get>, a C<make>, and an C<install> are not repeated.
10461 A C<test> is only repeated if the previous test was unsuccessful. The
10462 diagnostic message when CPAN.pm refuses to do something a second time
10463 is one of I<Has already been >C<unwrapped|made|tested successfully> or
10464 something similar. Another situation where CPAN refuses to act is an
10465 C<install> if the according C<test> was not successful.
10466
10467 In all these cases, the user can override the goatish behaviour by
10468 prepending the command with the word force, for example:
10469
10470   cpan> force get Foo
10471   cpan> force make AUTHOR/Bar-3.14.tar.gz
10472   cpan> force test Baz
10473   cpan> force install Acme::Meta
10474
10475 Each I<forced> command is executed with the according part of its
10476 memory erased.
10477
10478 The C<fforce> pragma is a variant that emulates a C<force get> which
10479 erases the entire memory followed by the action specified, effectively
10480 restarting the whole get/make/test/install procedure from scratch.
10481
10482 =item Lockfile
10483
10484 Interactive sessions maintain a lockfile, per default C<~/.cpan/.lock>.
10485 Batch jobs can run without a lockfile and do not disturb each other.
10486
10487 The shell offers to run in I<degraded mode> when another process is
10488 holding the lockfile. This is an experimental feature that is not yet
10489 tested very well. This second shell then does not write the history
10490 file, does not use the metadata file and has a different prompt.
10491
10492 =item Signals
10493
10494 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
10495 in the cpan-shell it is intended that you can press C<^C> anytime and
10496 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
10497 to clean up and leave the shell loop. You can emulate the effect of a
10498 SIGTERM by sending two consecutive SIGINTs, which usually means by
10499 pressing C<^C> twice.
10500
10501 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
10502 SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl
10503 Build.PL> subprocess.
10504
10505 =back
10506
10507 =head2 CPAN::Shell
10508
10509 The commands that are available in the shell interface are methods in
10510 the package CPAN::Shell. If you enter the shell command, all your
10511 input is split by the Text::ParseWords::shellwords() routine which
10512 acts like most shells do. The first word is being interpreted as the
10513 method to be called and the rest of the words are treated as arguments
10514 to this method. Continuation lines are supported if a line ends with a
10515 literal backslash.
10516
10517 =head2 autobundle
10518
10519 C<autobundle> writes a bundle file into the
10520 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
10521 a list of all modules that are both available from CPAN and currently
10522 installed within @INC. The name of the bundle file is based on the
10523 current date and a counter.
10524
10525 =head2 hosts
10526
10527 Note: this feature is still in alpha state and may change in future
10528 versions of CPAN.pm
10529
10530 This commands provides a statistical overview over recent download
10531 activities. The data for this is collected in the YAML file
10532 C<FTPstats.yml> in your C<cpan_home> directory. If no YAML module is
10533 configured or YAML not installed, then no stats are provided.
10534
10535 =head2 mkmyconfig
10536
10537 mkmyconfig() writes your own CPAN::MyConfig file into your ~/.cpan/
10538 directory so that you can save your own preferences instead of the
10539 system wide ones.
10540
10541 =head2 recent ***EXPERIMENTAL COMMAND***
10542
10543 The C<recent> command downloads a list of recent uploads to CPAN and
10544 displays them I<slowly>. While the command is running $SIG{INT} is
10545 defined to mean that the loop shall be left after having displayed the
10546 current item.
10547
10548 B<Note>: This command requires XML::LibXML installed.
10549
10550 B<Note>: This whole command currently is a bit klunky and will
10551 probably change in future versions of CPAN.pm but the general
10552 approach will likely stay.
10553
10554 B<Note>: See also L<smoke>
10555
10556 =head2 recompile
10557
10558 recompile() is a very special command in that it takes no argument and
10559 runs the make/test/install cycle with brute force over all installed
10560 dynamically loadable extensions (aka XS modules) with 'force' in
10561 effect. The primary purpose of this command is to finish a network
10562 installation. Imagine, you have a common source tree for two different
10563 architectures. You decide to do a completely independent fresh
10564 installation. You start on one architecture with the help of a Bundle
10565 file produced earlier. CPAN installs the whole Bundle for you, but
10566 when you try to repeat the job on the second architecture, CPAN
10567 responds with a C<"Foo up to date"> message for all modules. So you
10568 invoke CPAN's recompile on the second architecture and you're done.
10569
10570 Another popular use for C<recompile> is to act as a rescue in case your
10571 perl breaks binary compatibility. If one of the modules that CPAN uses
10572 is in turn depending on binary compatibility (so you cannot run CPAN
10573 commands), then you should try the CPAN::Nox module for recovery.
10574
10575 =head2 report Bundle|Distribution|Module
10576
10577 The C<report> command temporarily turns on the C<test_report> config
10578 variable, then runs the C<force test> command with the given
10579 arguments. The C<force> pragma is used to re-run the tests and repeat
10580 every step that might have failed before.
10581
10582 =head2 smoke ***EXPERIMENTAL COMMAND***
10583
10584 B<*** WARNING: this command downloads and executes software from CPAN to
10585 *** your computer of completely unknown status. You should never do
10586 *** this with your normal account and better have a dedicated well
10587 *** separated and secured machine to do this.>
10588
10589 The C<smoke> command takes the list of recent uploads to CPAN as
10590 provided by the C<recent> command and tests them all. While the
10591 command is running $SIG{INT} is defined to mean that the current item
10592 shall be skipped.
10593
10594 B<Note>: This whole command currently is a bit klunky and will
10595 probably change in future versions of CPAN.pm but the general
10596 approach will likely stay.
10597
10598 B<Note>: See also L<recent>
10599
10600 =head2 upgrade [Module|/Regex/]...
10601
10602 The C<upgrade> command first runs an C<r> command with the given
10603 arguments and then installs the newest versions of all modules that
10604 were listed by that.
10605
10606 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
10607
10608 Although it may be considered internal, the class hierarchy does matter
10609 for both users and programmer. CPAN.pm deals with above mentioned four
10610 classes, and all those classes share a set of methods. A classical
10611 single polymorphism is in effect. A metaclass object registers all
10612 objects of all kinds and indexes them with a string. The strings
10613 referencing objects have a separated namespace (well, not completely
10614 separated):
10615
10616          Namespace                         Class
10617
10618    words containing a "/" (slash)      Distribution
10619     words starting with Bundle::          Bundle
10620           everything else            Module or Author
10621
10622 Modules know their associated Distribution objects. They always refer
10623 to the most recent official release. Developers may mark their releases
10624 as unstable development versions (by inserting an underbar into the
10625 module version number which will also be reflected in the distribution
10626 name when you run 'make dist'), so the really hottest and newest
10627 distribution is not always the default.  If a module Foo circulates
10628 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
10629 way to install version 1.23 by saying
10630
10631     install Foo
10632
10633 This would install the complete distribution file (say
10634 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
10635 like to install version 1.23_90, you need to know where the
10636 distribution file resides on CPAN relative to the authors/id/
10637 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
10638 so you would have to say
10639
10640     install BAR/Foo-1.23_90.tar.gz
10641
10642 The first example will be driven by an object of the class
10643 CPAN::Module, the second by an object of class CPAN::Distribution.
10644
10645 =head2 Integrating local directories
10646
10647 Note: this feature is still in alpha state and may change in future
10648 versions of CPAN.pm
10649
10650 Distribution objects are normally distributions from the CPAN, but
10651 there is a slightly degenerate case for Distribution objects, too, of
10652 projects held on the local disk. These distribution objects have the
10653 same name as the local directory and end with a dot. A dot by itself
10654 is also allowed for the current directory at the time CPAN.pm was
10655 used. All actions such as C<make>, C<test>, and C<install> are applied
10656 directly to that directory. This gives the command C<cpan .> an
10657 interesting touch: while the normal mantra of installing a CPAN module
10658 without CPAN.pm is one of
10659
10660     perl Makefile.PL                 perl Build.PL
10661            ( go and get prerequisites )
10662     make                             ./Build
10663     make test                        ./Build test
10664     make install                     ./Build install
10665
10666 the command C<cpan .> does all of this at once. It figures out which
10667 of the two mantras is appropriate, fetches and installs all
10668 prerequisites, cares for them recursively and finally finishes the
10669 installation of the module in the current directory, be it a CPAN
10670 module or not.
10671
10672 The typical usage case is for private modules or working copies of
10673 projects from remote repositories on the local disk.
10674
10675 =head1 CONFIGURATION
10676
10677 When the CPAN module is used for the first time, a configuration
10678 dialog tries to determine a couple of site specific options. The
10679 result of the dialog is stored in a hash reference C< $CPAN::Config >
10680 in a file CPAN/Config.pm.
10681
10682 The default values defined in the CPAN/Config.pm file can be
10683 overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
10684 best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
10685 added to the search path of the CPAN module before the use() or
10686 require() statements. The mkmyconfig command writes this file for you.
10687
10688 The C<o conf> command has various bells and whistles:
10689
10690 =over
10691
10692 =item completion support
10693
10694 If you have a ReadLine module installed, you can hit TAB at any point
10695 of the commandline and C<o conf> will offer you completion for the
10696 built-in subcommands and/or config variable names.
10697
10698 =item displaying some help: o conf help
10699
10700 Displays a short help
10701
10702 =item displaying current values: o conf [KEY]
10703
10704 Displays the current value(s) for this config variable. Without KEY
10705 displays all subcommands and config variables.
10706
10707 Example:
10708
10709   o conf shell
10710
10711 If KEY starts and ends with a slash the string in between is
10712 interpreted as a regular expression and only keys matching this regex
10713 are displayed
10714
10715 Example:
10716
10717   o conf /color/
10718
10719 =item changing of scalar values: o conf KEY VALUE
10720
10721 Sets the config variable KEY to VALUE. The empty string can be
10722 specified as usual in shells, with C<''> or C<"">
10723
10724 Example:
10725
10726   o conf wget /usr/bin/wget
10727
10728 =item changing of list values: o conf KEY SHIFT|UNSHIFT|PUSH|POP|SPLICE|LIST
10729
10730 If a config variable name ends with C<list>, it is a list. C<o conf
10731 KEY shift> removes the first element of the list, C<o conf KEY pop>
10732 removes the last element of the list. C<o conf KEYS unshift LIST>
10733 prepends a list of values to the list, C<o conf KEYS push LIST>
10734 appends a list of valued to the list.
10735
10736 Likewise, C<o conf KEY splice LIST> passes the LIST to the according
10737 splice command.
10738
10739 Finally, any other list of arguments is taken as a new list value for
10740 the KEY variable discarding the previous value.
10741
10742 Examples:
10743
10744   o conf urllist unshift http://cpan.dev.local/CPAN
10745   o conf urllist splice 3 1
10746   o conf urllist http://cpan1.local http://cpan2.local ftp://ftp.perl.org
10747
10748 =item reverting to saved: o conf defaults
10749
10750 Reverts all config variables to the state in the saved config file.
10751
10752 =item saving the config: o conf commit
10753
10754 Saves all config variables to the current config file (CPAN/Config.pm
10755 or CPAN/MyConfig.pm that was loaded at start).
10756
10757 =back
10758
10759 The configuration dialog can be started any time later again by
10760 issuing the command C< o conf init > in the CPAN shell. A subset of
10761 the configuration dialog can be run by issuing C<o conf init WORD>
10762 where WORD is any valid config variable or a regular expression.
10763
10764 =head2 Config Variables
10765
10766 Currently the following keys in the hash reference $CPAN::Config are
10767 defined:
10768
10769   applypatch         path to external prg
10770   auto_commit        commit all changes to config variables to disk
10771   build_cache        size of cache for directories to build modules
10772   build_dir          locally accessible directory to build modules
10773   build_dir_reuse    boolean if distros in build_dir are persistent
10774   build_requires_install_policy
10775                      to install or not to install when a module is
10776                      only needed for building. yes|no|ask/yes|ask/no
10777   bzip2              path to external prg
10778   cache_metadata     use serializer to cache metadata
10779   commands_quote     prefered character to use for quoting external
10780                      commands when running them. Defaults to double
10781                      quote on Windows, single tick everywhere else;
10782                      can be set to space to disable quoting
10783   check_sigs         if signatures should be verified
10784   colorize_debug     Term::ANSIColor attributes for debugging output
10785   colorize_output    boolean if Term::ANSIColor should colorize output
10786   colorize_print     Term::ANSIColor attributes for normal output
10787   colorize_warn      Term::ANSIColor attributes for warnings
10788   commandnumber_in_prompt
10789                      boolean if you want to see current command number
10790   cpan_home          local directory reserved for this package
10791   curl               path to external prg
10792   dontload_hash      DEPRECATED
10793   dontload_list      arrayref: modules in the list will not be
10794                      loaded by the CPAN::has_inst() routine
10795   ftp                path to external prg
10796   ftp_passive        if set, the envariable FTP_PASSIVE is set for downloads
10797   ftp_proxy          proxy host for ftp requests
10798   getcwd             see below
10799   gpg                path to external prg
10800   gzip               location of external program gzip
10801   histfile           file to maintain history between sessions
10802   histsize           maximum number of lines to keep in histfile
10803   http_proxy         proxy host for http requests
10804   inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
10805                      after this many seconds inactivity. Set to 0 to
10806                      never break.
10807   index_expire       after this many days refetch index files
10808   inhibit_startup_message
10809                      if true, does not print the startup message
10810   keep_source_where  directory in which to keep the source (if we do)
10811   load_module_verbosity
10812                      report loading of optional modules used by CPAN.pm
10813   lynx               path to external prg
10814   make               location of external make program
10815   make_arg           arguments that should always be passed to 'make'
10816   make_install_make_command
10817                      the make command for running 'make install', for
10818                      example 'sudo make'
10819   make_install_arg   same as make_arg for 'make install'
10820   makepl_arg         arguments passed to 'perl Makefile.PL'
10821   mbuild_arg         arguments passed to './Build'
10822   mbuild_install_arg arguments passed to './Build install'
10823   mbuild_install_build_command
10824                      command to use instead of './Build' when we are
10825                      in the install stage, for example 'sudo ./Build'
10826   mbuildpl_arg       arguments passed to 'perl Build.PL'
10827   ncftp              path to external prg
10828   ncftpget           path to external prg
10829   no_proxy           don't proxy to these hosts/domains (comma separated list)
10830   pager              location of external program more (or any pager)
10831   password           your password if you CPAN server wants one
10832   patch              path to external prg
10833   prefer_installer   legal values are MB and EUMM: if a module comes
10834                      with both a Makefile.PL and a Build.PL, use the
10835                      former (EUMM) or the latter (MB); if the module
10836                      comes with only one of the two, that one will be
10837                      used in any case
10838   prerequisites_policy
10839                      what to do if you are missing module prerequisites
10840                      ('follow' automatically, 'ask' me, or 'ignore')
10841   prefs_dir          local directory to store per-distro build options
10842   proxy_user         username for accessing an authenticating proxy
10843   proxy_pass         password for accessing an authenticating proxy
10844   randomize_urllist  add some randomness to the sequence of the urllist
10845   scan_cache         controls scanning of cache ('atstart' or 'never')
10846   shell              your favorite shell
10847   show_unparsable_versions
10848                      boolean if r command tells which modules are versionless
10849   show_upload_date   boolean if commands should try to determine upload date
10850   show_zero_versions boolean if r command tells for which modules $version==0
10851   tar                location of external program tar
10852   tar_verbosity      verbosity level for the tar command
10853   term_is_latin      deprecated: if true Unicode is translated to ISO-8859-1
10854                      (and nonsense for characters outside latin range)
10855   term_ornaments     boolean to turn ReadLine ornamenting on/off
10856   test_report        email test reports (if CPAN::Reporter is installed)
10857   unzip              location of external program unzip
10858   urllist            arrayref to nearby CPAN sites (or equivalent locations)
10859   use_sqlite         use CPAN::SQLite for metadata storage (fast and lean)
10860   username           your username if you CPAN server wants one
10861   wait_list          arrayref to a wait server to try (See CPAN::WAIT)
10862   wget               path to external prg
10863   yaml_load_code     enable YAML code deserialisation
10864   yaml_module        which module to use to read/write YAML files
10865
10866 You can set and query each of these options interactively in the cpan
10867 shell with the C<o conf> or the C<o conf init> command as specified below.
10868
10869 =over 2
10870
10871 =item C<o conf E<lt>scalar optionE<gt>>
10872
10873 prints the current value of the I<scalar option>
10874
10875 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
10876
10877 Sets the value of the I<scalar option> to I<value>
10878
10879 =item C<o conf E<lt>list optionE<gt>>
10880
10881 prints the current value of the I<list option> in MakeMaker's
10882 neatvalue format.
10883
10884 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
10885
10886 shifts or pops the array in the I<list option> variable
10887
10888 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
10889
10890 works like the corresponding perl commands.
10891
10892 =item interactive editing: o conf init [MATCH|LIST]
10893
10894 Runs an interactive configuration dialog for matching variables.
10895 Without argument runs the dialog over all supported config variables.
10896 To specify a MATCH the argument must be enclosed by slashes.
10897
10898 Examples:
10899
10900   o conf init ftp_passive ftp_proxy
10901   o conf init /color/
10902
10903 Note: this method of setting config variables often provides more
10904 explanation about the functioning of a variable than the manpage.
10905
10906 =back
10907
10908 =head2 CPAN::anycwd($path): Note on config variable getcwd
10909
10910 CPAN.pm changes the current working directory often and needs to
10911 determine its own current working directory. Per default it uses
10912 Cwd::cwd but if this doesn't work on your system for some reason,
10913 alternatives can be configured according to the following table:
10914
10915 =over 4
10916
10917 =item cwd
10918
10919 Calls Cwd::cwd
10920
10921 =item getcwd
10922
10923 Calls Cwd::getcwd
10924
10925 =item fastcwd
10926
10927 Calls Cwd::fastcwd
10928
10929 =item backtickcwd
10930
10931 Calls the external command cwd.
10932
10933 =back
10934
10935 =head2 Note on the format of the urllist parameter
10936
10937 urllist parameters are URLs according to RFC 1738. We do a little
10938 guessing if your URL is not compliant, but if you have problems with
10939 C<file> URLs, please try the correct format. Either:
10940
10941     file://localhost/whatever/ftp/pub/CPAN/
10942
10943 or
10944
10945     file:///home/ftp/pub/CPAN/
10946
10947 =head2 The urllist parameter has CD-ROM support
10948
10949 The C<urllist> parameter of the configuration table contains a list of
10950 URLs that are to be used for downloading. If the list contains any
10951 C<file> URLs, CPAN always tries to get files from there first. This
10952 feature is disabled for index files. So the recommendation for the
10953 owner of a CD-ROM with CPAN contents is: include your local, possibly
10954 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
10955
10956   o conf urllist push file://localhost/CDROM/CPAN
10957
10958 CPAN.pm will then fetch the index files from one of the CPAN sites
10959 that come at the beginning of urllist. It will later check for each
10960 module if there is a local copy of the most recent version.
10961
10962 Another peculiarity of urllist is that the site that we could
10963 successfully fetch the last file from automatically gets a preference
10964 token and is tried as the first site for the next request. So if you
10965 add a new site at runtime it may happen that the previously preferred
10966 site will be tried another time. This means that if you want to disallow
10967 a site for the next transfer, it must be explicitly removed from
10968 urllist.
10969
10970 =head2 Maintaining the urllist parameter
10971
10972 If you have YAML.pm (or some other YAML module configured in
10973 C<yaml_module>) installed, CPAN.pm collects a few statistical data
10974 about recent downloads. You can view the statistics with the C<hosts>
10975 command or inspect them directly by looking into the C<FTPstats.yml>
10976 file in your C<cpan_home> directory.
10977
10978 To get some interesting statistics it is recommended to set the
10979 C<randomize_urllist> parameter that introduces some amount of
10980 randomness into the URL selection.
10981
10982 =head2 The C<requires> and C<build_requires> dependency declarations
10983
10984 Since CPAN.pm version 1.88_51 modules declared as C<build_requires> by
10985 a distribution are treated differently depending on the config
10986 variable C<build_requires_install_policy>. By setting
10987 C<build_requires_install_policy> to C<no> such a module is not being
10988 installed. It is only built and tested and then kept in the list of
10989 tested but uninstalled modules. As such it is available during the
10990 build of the dependent module by integrating the path to the
10991 C<blib/arch> and C<blib/lib> directories in the environment variable
10992 PERL5LIB. If C<build_requires_install_policy> is set ti C<yes>, then
10993 both modules declared as C<requires> and those declared as
10994 C<build_requires> are treated alike. By setting to C<ask/yes> or
10995 C<ask/no>, CPAN.pm asks the user and sets the default accordingly.
10996
10997 =head2 Configuration for individual distributions (I<Distroprefs>)
10998
10999 (B<Note:> This feature has been introduced in CPAN.pm 1.8854 and is
11000 still considered beta quality)
11001
11002 Distributions on the CPAN usually behave according to what we call the
11003 CPAN mantra. Or since the event of Module::Build we should talk about
11004 two mantras:
11005
11006     perl Makefile.PL     perl Build.PL
11007     make                 ./Build
11008     make test            ./Build test
11009     make install         ./Build install
11010
11011 But some modules cannot be built with this mantra. They try to get
11012 some extra data from the user via the environment, extra arguments or
11013 interactively thus disturbing the installation of large bundles like
11014 Phalanx100 or modules with many dependencies like Plagger.
11015
11016 The distroprefs system of C<CPAN.pm> addresses this problem by
11017 allowing the user to specify extra informations and recipes in YAML
11018 files to either
11019
11020 =over
11021
11022 =item
11023
11024 pass additional arguments to one of the four commands,
11025
11026 =item
11027
11028 set environment variables
11029
11030 =item
11031
11032 instantiate an Expect object that reads from the console, waits for
11033 some regular expressions and enters some answers
11034
11035 =item
11036
11037 temporarily override assorted C<CPAN.pm> configuration variables
11038
11039 =item
11040
11041 specify dependencies that the original maintainer forgot to specify
11042
11043 =item
11044
11045 disable the installation of an object altogether
11046
11047 =back
11048
11049 See the YAML and Data::Dumper files that come with the C<CPAN.pm>
11050 distribution in the C<distroprefs/> directory for examples.
11051
11052 =head2 Filenames
11053
11054 The YAML files themselves must have the C<.yml> extension, all other
11055 files are ignored (for two exceptions see I<Fallback Data::Dumper and
11056 Storable> below). The containing directory can be specified in
11057 C<CPAN.pm> in the C<prefs_dir> config variable. Try C<o conf init
11058 prefs_dir> in the CPAN shell to set and activate the distroprefs
11059 system.
11060
11061 Every YAML file may contain arbitrary documents according to the YAML
11062 specification and every single document is treated as an entity that
11063 can specify the treatment of a single distribution.
11064
11065 The names of the files can be picked freely, C<CPAN.pm> always reads
11066 all files (in alphabetical order) and takes the key C<match> (see
11067 below in I<Language Specs>) as a hashref containing match criteria
11068 that determine if the current distribution matches the YAML document
11069 or not.
11070
11071 =head2 Fallback Data::Dumper and Storable
11072
11073 If neither your configured C<yaml_module> nor YAML.pm is installed
11074 CPAN.pm falls back to using Data::Dumper and Storable and looks for
11075 files with the extensions C<.dd> or C<.st> in the C<prefs_dir>
11076 directory. These files are expected to contain one or more hashrefs.
11077 For Data::Dumper generated files, this is expected to be done with by
11078 defining C<$VAR1>, C<$VAR2>, etc. The YAML shell would produce these
11079 with the command
11080
11081     ysh < somefile.yml > somefile.dd
11082
11083 For Storable files the rule is that they must be constructed such that
11084 C<Storable::retrieve(file)> returns an array reference and the array
11085 elements represent one distropref object each. The conversion from
11086 YAML would look like so:
11087
11088     perl -MYAML=LoadFile -MStorable=nstore -e '
11089         @y=LoadFile(shift);
11090         nstore(\@y, shift)' somefile.yml somefile.st
11091
11092 In bootstrapping situations it is usually sufficient to translate only
11093 a few YAML files to Data::Dumper for the crucial modules like
11094 C<YAML::Syck>, C<YAML.pm> and C<Expect.pm>. If you prefer Storable
11095 over Data::Dumper, remember to pull out a Storable version that writes
11096 an older format than all the other Storable versions that will need to
11097 read them.
11098
11099 =head2 Blueprint
11100
11101 The following example contains all supported keywords and structures
11102 with the exception of C<eexpect> which can be used instead of
11103 C<expect>.
11104
11105   ---
11106   comment: "Demo"
11107   match:
11108     module: "Dancing::Queen"
11109     distribution: "^CHACHACHA/Dancing-"
11110     perl: "/usr/local/cariba-perl/bin/perl"
11111     perlconfig:
11112       archname: "freebsd"
11113   disabled: 1
11114   cpanconfig:
11115     make: gmake
11116   pl:
11117     args:
11118       - "--somearg=specialcase"
11119
11120     env: {}
11121
11122     expect:
11123       - "Which is your favorite fruit"
11124       - "apple\n"
11125
11126   make:
11127     args:
11128       - all
11129       - extra-all
11130
11131     env: {}
11132
11133     expect: []
11134
11135     commendline: "echo SKIPPING make"
11136
11137   test:
11138     args: []
11139
11140     env: {}
11141
11142     expect: []
11143
11144   install:
11145     args: []
11146
11147     env:
11148       WANT_TO_INSTALL: YES
11149
11150     expect:
11151       - "Do you really want to install"
11152       - "y\n"
11153
11154   patches:
11155     - "ABCDE/Fedcba-3.14-ABCDE-01.patch"
11156
11157   depends:
11158     configure_requires:
11159       LWP: 5.8
11160     build_requires:
11161       Test::Exception: 0.25
11162     requires:
11163       Spiffy: 0.30
11164
11165
11166 =head2 Language Specs
11167
11168 Every YAML document represents a single hash reference. The valid keys
11169 in this hash are as follows:
11170
11171 =over
11172
11173 =item comment [scalar]
11174
11175 A comment
11176
11177 =item cpanconfig [hash]
11178
11179 Temporarily override assorted C<CPAN.pm> configuration variables.
11180
11181 Supported are: C<build_requires_install_policy>, C<check_sigs>,
11182 C<make>, C<make_install_make_command>, C<prefer_installer>,
11183 C<test_report>. Please report as a bug when you need another one
11184 supported.
11185
11186 =item depends [hash] *** EXPERIMENTAL FEATURE ***
11187
11188 All three types, namely C<configure_requires>, C<build_requires>, and
11189 C<requires> are supported in the way specified in the META.yml
11190 specification. The current implementation I<merges> the specified
11191 dependencies with those declared by the package maintainer. In a
11192 future implementation this may be changed to override the original
11193 declaration.
11194
11195 =item disabled [boolean]
11196
11197 Specifies that this distribution shall not be processed at all.
11198
11199 =item goto [string]
11200
11201 The canonical name of a delegate distribution that shall be installed
11202 instead. Useful when a new version, although it tests OK itself,
11203 breaks something else or a developer release or a fork is already
11204 uploaded that is better than the last released version.
11205
11206 =item install [hash]
11207
11208 Processing instructions for the C<make install> or C<./Build install>
11209 phase of the CPAN mantra. See below under I<Processiong Instructions>.
11210
11211 =item make [hash]
11212
11213 Processing instructions for the C<make> or C<./Build> phase of the
11214 CPAN mantra. See below under I<Processiong Instructions>.
11215
11216 =item match [hash]
11217
11218 A hashref with one or more of the keys C<distribution>, C<modules>,
11219 C<perl>, and C<perlconfig> that specify if a document is targeted at a
11220 specific CPAN distribution or installation.
11221
11222 The corresponding values are interpreted as regular expressions. The
11223 C<distribution> related one will be matched against the canonical
11224 distribution name, e.g. "AUTHOR/Foo-Bar-3.14.tar.gz".
11225
11226 The C<module> related one will be matched against I<all> modules
11227 contained in the distribution until one module matches.
11228
11229 The C<perl> related one will be matched against C<$^X>.
11230
11231 The value associated with C<perlconfig> is itself a hashref that is
11232 matched against corresponding values in the C<%Config::Config> hash
11233 living in the C< Config.pm > module.
11234
11235 If more than one restriction of C<module>, C<distribution>, and
11236 C<perl> is specified, the results of the separately computed match
11237 values must all match. If this is the case then the hashref
11238 represented by the YAML document is returned as the preference
11239 structure for the current distribution.
11240
11241 =item patches [array]
11242
11243 An array of patches on CPAN or on the local disk to be applied in
11244 order via the external patch program. If the value for the C<-p>
11245 parameter is C<0> or C<1> is determined by reading the patch
11246 beforehand.
11247
11248 Note: if the C<applypatch> program is installed and C<CPAN::Config>
11249 knows about it B<and> a patch is written by the C<makepatch> program,
11250 then C<CPAN.pm> lets C<applypatch> apply the patch. Both C<makepatch>
11251 and C<applypatch> are available from CPAN in the C<JV/makepatch-*>
11252 distribution.
11253
11254 =item pl [hash]
11255
11256 Processing instructions for the C<perl Makefile.PL> or C<perl
11257 Build.PL> phase of the CPAN mantra. See below under I<Processiong
11258 Instructions>.
11259
11260 =item test [hash]
11261
11262 Processing instructions for the C<make test> or C<./Build test> phase
11263 of the CPAN mantra. See below under I<Processiong Instructions>.
11264
11265 =back
11266
11267 =head2 Processing Instructions
11268
11269 =over
11270
11271 =item args [array]
11272
11273 Arguments to be added to the command line
11274
11275 =item commandline
11276
11277 A full commandline that will be executed as it stands by a system
11278 call. During the execution the environment variable PERL will is set
11279 to $^X. If C<commandline> is specified, the content of C<args> is not
11280 used.
11281
11282 =item eexpect [hash]
11283
11284 Extended C<expect>. This is a hash reference with four allowed keys,
11285 C<mode>, C<timeout>, C<reuse>, and C<talk>.
11286
11287 C<mode> may have the values C<deterministic> for the case where all
11288 questions come in the order written down and C<anyorder> for the case
11289 where the questions may come in any order. The default mode is
11290 C<deterministic>.
11291
11292 C<timeout> denotes a timeout in seconds. Floating point timeouts are
11293 OK. In the case of a C<mode=deterministic> the timeout denotes the
11294 timeout per question, in the case of C<mode=anyorder> it denotes the
11295 timeout per byte received from the stream or questions.
11296
11297 C<talk> is a reference to an array that contains alternating questions
11298 and answers. Questions are regular expressions and answers are literal
11299 strings. The Expect module will then watch the stream coming from the
11300 execution of the external program (C<perl Makefile.PL>, C<perl
11301 Build.PL>, C<make>, etc.).
11302
11303 In the case of C<mode=deterministic> the CPAN.pm will inject the
11304 according answer as soon as the stream matches the regular expression.
11305
11306 In the case of C<mode=anyorder> CPAN.pm will answer a question as soon
11307 as the timeout is reached for the next byte in the input stream. In
11308 this mode you can use the C<reuse> parameter to decide what shall
11309 happen with a question-answer pair after it has been used. In the
11310 default case (reuse=0) it is removed from the array, so it cannot be
11311 used again accidentally. In this case, if you want to answer the
11312 question C<Do you really want to do that> several times, then it must
11313 be included in the array at least as often as you want this answer to
11314 be given. Setting the parameter C<reuse> to 1 makes this repetition
11315 unnecessary.
11316
11317 =item env [hash]
11318
11319 Environment variables to be set during the command
11320
11321 =item expect [array]
11322
11323 C<< expect: <array> >> is a short notation for
11324
11325   eexpect:
11326     mode: deterministic
11327     timeout: 15
11328     talk: <array>
11329
11330 =back
11331
11332 =head2 Schema verification with C<Kwalify>
11333
11334 If you have the C<Kwalify> module installed (which is part of the
11335 Bundle::CPANxxl), then all your distroprefs files are checked for
11336 syntactical correctness.
11337
11338 =head2 Example Distroprefs Files
11339
11340 C<CPAN.pm> comes with a collection of example YAML files. Note that these
11341 are really just examples and should not be used without care because
11342 they cannot fit everybody's purpose. After all the authors of the
11343 packages that ask questions had a need to ask, so you should watch
11344 their questions and adjust the examples to your environment and your
11345 needs. You have beend warned:-)
11346
11347 =head1 PROGRAMMER'S INTERFACE
11348
11349 If you do not enter the shell, the available shell commands are both
11350 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
11351 functions in the calling package (C<install(...)>).  Before calling low-level
11352 commands it makes sense to initialize components of CPAN you need, e.g.:
11353
11354   CPAN::HandleConfig->load;
11355   CPAN::Shell::setup_output;
11356   CPAN::Index->reload;
11357
11358 High-level commands do such initializations automatically.
11359
11360 There's currently only one class that has a stable interface -
11361 CPAN::Shell. All commands that are available in the CPAN shell are
11362 methods of the class CPAN::Shell. Each of the commands that produce
11363 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
11364 the IDs of all modules within the list.
11365
11366 =over 2
11367
11368 =item expand($type,@things)
11369
11370 The IDs of all objects available within a program are strings that can
11371 be expanded to the corresponding real objects with the
11372 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
11373 list of CPAN::Module objects according to the C<@things> arguments
11374 given. In scalar context it only returns the first element of the
11375 list.
11376
11377 =item expandany(@things)
11378
11379 Like expand, but returns objects of the appropriate type, i.e.
11380 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
11381 CPAN::Distribution objects for distributions. Note: it does not expand
11382 to CPAN::Author objects.
11383
11384 =item Programming Examples
11385
11386 This enables the programmer to do operations that combine
11387 functionalities that are available in the shell.
11388
11389     # install everything that is outdated on my disk:
11390     perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
11391
11392     # install my favorite programs if necessary:
11393     for $mod (qw(Net::FTP Digest::SHA Data::Dumper)) {
11394         CPAN::Shell->install($mod);
11395     }
11396
11397     # list all modules on my disk that have no VERSION number
11398     for $mod (CPAN::Shell->expand("Module","/./")) {
11399         next unless $mod->inst_file;
11400         # MakeMaker convention for undefined $VERSION:
11401         next unless $mod->inst_version eq "undef";
11402         print "No VERSION in ", $mod->id, "\n";
11403     }
11404
11405     # find out which distribution on CPAN contains a module:
11406     print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
11407
11408 Or if you want to write a cronjob to watch The CPAN, you could list
11409 all modules that need updating. First a quick and dirty way:
11410
11411     perl -e 'use CPAN; CPAN::Shell->r;'
11412
11413 If you don't want to get any output in the case that all modules are
11414 up to date, you can parse the output of above command for the regular
11415 expression //modules are up to date// and decide to mail the output
11416 only if it doesn't match. Ick?
11417
11418 If you prefer to do it more in a programmer style in one single
11419 process, maybe something like this suits you better:
11420
11421   # list all modules on my disk that have newer versions on CPAN
11422   for $mod (CPAN::Shell->expand("Module","/./")) {
11423     next unless $mod->inst_file;
11424     next if $mod->uptodate;
11425     printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
11426         $mod->id, $mod->inst_version, $mod->cpan_version;
11427   }
11428
11429 If that gives you too much output every day, you maybe only want to
11430 watch for three modules. You can write
11431
11432   for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")) {
11433
11434 as the first line instead. Or you can combine some of the above
11435 tricks:
11436
11437   # watch only for a new mod_perl module
11438   $mod = CPAN::Shell->expand("Module","mod_perl");
11439   exit if $mod->uptodate;
11440   # new mod_perl arrived, let me know all update recommendations
11441   CPAN::Shell->r;
11442
11443 =back
11444
11445 =head2 Methods in the other Classes
11446
11447 =over 4
11448
11449 =item CPAN::Author::as_glimpse()
11450
11451 Returns a one-line description of the author
11452
11453 =item CPAN::Author::as_string()
11454
11455 Returns a multi-line description of the author
11456
11457 =item CPAN::Author::email()
11458
11459 Returns the author's email address
11460
11461 =item CPAN::Author::fullname()
11462
11463 Returns the author's name
11464
11465 =item CPAN::Author::name()
11466
11467 An alias for fullname
11468
11469 =item CPAN::Bundle::as_glimpse()
11470
11471 Returns a one-line description of the bundle
11472
11473 =item CPAN::Bundle::as_string()
11474
11475 Returns a multi-line description of the bundle
11476
11477 =item CPAN::Bundle::clean()
11478
11479 Recursively runs the C<clean> method on all items contained in the bundle.
11480
11481 =item CPAN::Bundle::contains()
11482
11483 Returns a list of objects' IDs contained in a bundle. The associated
11484 objects may be bundles, modules or distributions.
11485
11486 =item CPAN::Bundle::force($method,@args)
11487
11488 Forces CPAN to perform a task that it normally would have refused to
11489 do. Force takes as arguments a method name to be called and any number
11490 of additional arguments that should be passed to the called method.
11491 The internals of the object get the needed changes so that CPAN.pm
11492 does not refuse to take the action. The C<force> is passed recursively
11493 to all contained objects. See also the section above on the C<force>
11494 and the C<fforce> pragma.
11495
11496 =item CPAN::Bundle::get()
11497
11498 Recursively runs the C<get> method on all items contained in the bundle
11499
11500 =item CPAN::Bundle::inst_file()
11501
11502 Returns the highest installed version of the bundle in either @INC or
11503 C<$CPAN::Config->{cpan_home}>. Note that this is different from
11504 CPAN::Module::inst_file.
11505
11506 =item CPAN::Bundle::inst_version()
11507
11508 Like CPAN::Bundle::inst_file, but returns the $VERSION
11509
11510 =item CPAN::Bundle::uptodate()
11511
11512 Returns 1 if the bundle itself and all its members are uptodate.
11513
11514 =item CPAN::Bundle::install()
11515
11516 Recursively runs the C<install> method on all items contained in the bundle
11517
11518 =item CPAN::Bundle::make()
11519
11520 Recursively runs the C<make> method on all items contained in the bundle
11521
11522 =item CPAN::Bundle::readme()
11523
11524 Recursively runs the C<readme> method on all items contained in the bundle
11525
11526 =item CPAN::Bundle::test()
11527
11528 Recursively runs the C<test> method on all items contained in the bundle
11529
11530 =item CPAN::Distribution::as_glimpse()
11531
11532 Returns a one-line description of the distribution
11533
11534 =item CPAN::Distribution::as_string()
11535
11536 Returns a multi-line description of the distribution
11537
11538 =item CPAN::Distribution::author
11539
11540 Returns the CPAN::Author object of the maintainer who uploaded this
11541 distribution
11542
11543 =item CPAN::Distribution::pretty_id()
11544
11545 Returns a string of the form "AUTHORID/TARBALL", where AUTHORID is the
11546 author's PAUSE ID and TARBALL is the distribution filename.
11547
11548 =item CPAN::Distribution::base_id()
11549
11550 Returns the distribution filename without any archive suffix.  E.g
11551 "Foo-Bar-0.01"
11552
11553 =item CPAN::Distribution::clean()
11554
11555 Changes to the directory where the distribution has been unpacked and
11556 runs C<make clean> there.
11557
11558 =item CPAN::Distribution::containsmods()
11559
11560 Returns a list of IDs of modules contained in a distribution file.
11561 Only works for distributions listed in the 02packages.details.txt.gz
11562 file. This typically means that only the most recent version of a
11563 distribution is covered.
11564
11565 =item CPAN::Distribution::cvs_import()
11566
11567 Changes to the directory where the distribution has been unpacked and
11568 runs something like
11569
11570     cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
11571
11572 there.
11573
11574 =item CPAN::Distribution::dir()
11575
11576 Returns the directory into which this distribution has been unpacked.
11577
11578 =item CPAN::Distribution::force($method,@args)
11579
11580 Forces CPAN to perform a task that it normally would have refused to
11581 do. Force takes as arguments a method name to be called and any number
11582 of additional arguments that should be passed to the called method.
11583 The internals of the object get the needed changes so that CPAN.pm
11584 does not refuse to take the action. See also the section above on the
11585 C<force> and the C<fforce> pragma.
11586
11587 =item CPAN::Distribution::get()
11588
11589 Downloads the distribution from CPAN and unpacks it. Does nothing if
11590 the distribution has already been downloaded and unpacked within the
11591 current session.
11592
11593 =item CPAN::Distribution::install()
11594
11595 Changes to the directory where the distribution has been unpacked and
11596 runs the external command C<make install> there. If C<make> has not
11597 yet been run, it will be run first. A C<make test> will be issued in
11598 any case and if this fails, the install will be canceled. The
11599 cancellation can be avoided by letting C<force> run the C<install> for
11600 you.
11601
11602 This install method has only the power to install the distribution if
11603 there are no dependencies in the way. To install an object and all of
11604 its dependencies, use CPAN::Shell->install.
11605
11606 Note that install() gives no meaningful return value. See uptodate().
11607
11608 =item CPAN::Distribution::install_tested()
11609
11610 Install all the distributions that have been tested sucessfully but
11611 not yet installed. See also C<is_tested>.
11612
11613 =item CPAN::Distribution::isa_perl()
11614
11615 Returns 1 if this distribution file seems to be a perl distribution.
11616 Normally this is derived from the file name only, but the index from
11617 CPAN can contain a hint to achieve a return value of true for other
11618 filenames too.
11619
11620 =item CPAN::Distribution::is_tested()
11621
11622 List all the distributions that have been tested sucessfully but not
11623 yet installed. See also C<install_tested>.
11624
11625 =item CPAN::Distribution::look()
11626
11627 Changes to the directory where the distribution has been unpacked and
11628 opens a subshell there. Exiting the subshell returns.
11629
11630 =item CPAN::Distribution::make()
11631
11632 First runs the C<get> method to make sure the distribution is
11633 downloaded and unpacked. Changes to the directory where the
11634 distribution has been unpacked and runs the external commands C<perl
11635 Makefile.PL> or C<perl Build.PL> and C<make> there.
11636
11637 =item CPAN::Distribution::perldoc()
11638
11639 Downloads the pod documentation of the file associated with a
11640 distribution (in html format) and runs it through the external
11641 command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
11642 isn't available, it converts it to plain text with external
11643 command html2text and runs it through the pager specified
11644 in C<$CPAN::Config->{pager}>
11645
11646 =item CPAN::Distribution::prefs()
11647
11648 Returns the hash reference from the first matching YAML file that the
11649 user has deposited in the C<prefs_dir/> directory. The first
11650 succeeding match wins. The files in the C<prefs_dir/> are processed
11651 alphabetically and the canonical distroname (e.g.
11652 AUTHOR/Foo-Bar-3.14.tar.gz) is matched against the regular expressions
11653 stored in the $root->{match}{distribution} attribute value.
11654 Additionally all module names contained in a distribution are matched
11655 agains the regular expressions in the $root->{match}{module} attribute
11656 value. The two match values are ANDed together. Each of the two
11657 attributes are optional.
11658
11659 =item CPAN::Distribution::prereq_pm()
11660
11661 Returns the hash reference that has been announced by a distribution
11662 as the the C<requires> and C<build_requires> elements. These can be
11663 declared either by the C<META.yml> (if authoritative) or can be
11664 deposited after the run of C<Build.PL> in the file C<./_build/prereqs>
11665 or after the run of C<Makfile.PL> written as the C<PREREQ_PM> hash in
11666 a comment in the produced C<Makefile>. I<Note>: this method only works
11667 after an attempt has been made to C<make> the distribution. Returns
11668 undef otherwise.
11669
11670 =item CPAN::Distribution::readme()
11671
11672 Downloads the README file associated with a distribution and runs it
11673 through the pager specified in C<$CPAN::Config->{pager}>.
11674
11675 =item CPAN::Distribution::reports()
11676
11677 Downloads report data for this distribution from cpantesters.perl.org
11678 and displays a subset of them.
11679
11680 =item CPAN::Distribution::read_yaml()
11681
11682 Returns the content of the META.yml of this distro as a hashref. Note:
11683 works only after an attempt has been made to C<make> the distribution.
11684 Returns undef otherwise. Also returns undef if the content of META.yml
11685 is not authoritative. (The rules about what exactly makes the content
11686 authoritative are still in flux.)
11687
11688 =item CPAN::Distribution::test()
11689
11690 Changes to the directory where the distribution has been unpacked and
11691 runs C<make test> there.
11692
11693 =item CPAN::Distribution::uptodate()
11694
11695 Returns 1 if all the modules contained in the distribution are
11696 uptodate. Relies on containsmods.
11697
11698 =item CPAN::Index::force_reload()
11699
11700 Forces a reload of all indices.
11701
11702 =item CPAN::Index::reload()
11703
11704 Reloads all indices if they have not been read for more than
11705 C<$CPAN::Config->{index_expire}> days.
11706
11707 =item CPAN::InfoObj::dump()
11708
11709 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
11710 inherit this method. It prints the data structure associated with an
11711 object. Useful for debugging. Note: the data structure is considered
11712 internal and thus subject to change without notice.
11713
11714 =item CPAN::Module::as_glimpse()
11715
11716 Returns a one-line description of the module in four columns: The
11717 first column contains the word C<Module>, the second column consists
11718 of one character: an equals sign if this module is already installed
11719 and uptodate, a less-than sign if this module is installed but can be
11720 upgraded, and a space if the module is not installed. The third column
11721 is the name of the module and the fourth column gives maintainer or
11722 distribution information.
11723
11724 =item CPAN::Module::as_string()
11725
11726 Returns a multi-line description of the module
11727
11728 =item CPAN::Module::clean()
11729
11730 Runs a clean on the distribution associated with this module.
11731
11732 =item CPAN::Module::cpan_file()
11733
11734 Returns the filename on CPAN that is associated with the module.
11735
11736 =item CPAN::Module::cpan_version()
11737
11738 Returns the latest version of this module available on CPAN.
11739
11740 =item CPAN::Module::cvs_import()
11741
11742 Runs a cvs_import on the distribution associated with this module.
11743
11744 =item CPAN::Module::description()
11745
11746 Returns a 44 character description of this module. Only available for
11747 modules listed in The Module List (CPAN/modules/00modlist.long.html
11748 or 00modlist.long.txt.gz)
11749
11750 =item CPAN::Module::distribution()
11751
11752 Returns the CPAN::Distribution object that contains the current
11753 version of this module.
11754
11755 =item CPAN::Module::dslip_status()
11756
11757 Returns a hash reference. The keys of the hash are the letters C<D>,
11758 C<S>, C<L>, C<I>, and <P>, for development status, support level,
11759 language, interface and public licence respectively. The data for the
11760 DSLIP status are collected by pause.perl.org when authors register
11761 their namespaces. The values of the 5 hash elements are one-character
11762 words whose meaning is described in the table below. There are also 5
11763 hash elements C<DV>, C<SV>, C<LV>, C<IV>, and <PV> that carry a more
11764 verbose value of the 5 status variables.
11765
11766 Where the 'DSLIP' characters have the following meanings:
11767
11768   D - Development Stage  (Note: *NO IMPLIED TIMESCALES*):
11769     i   - Idea, listed to gain consensus or as a placeholder
11770     c   - under construction but pre-alpha (not yet released)
11771     a/b - Alpha/Beta testing
11772     R   - Released
11773     M   - Mature (no rigorous definition)
11774     S   - Standard, supplied with Perl 5
11775
11776   S - Support Level:
11777     m   - Mailing-list
11778     d   - Developer
11779     u   - Usenet newsgroup comp.lang.perl.modules
11780     n   - None known, try comp.lang.perl.modules
11781     a   - abandoned; volunteers welcome to take over maintainance
11782
11783   L - Language Used:
11784     p   - Perl-only, no compiler needed, should be platform independent
11785     c   - C and perl, a C compiler will be needed
11786     h   - Hybrid, written in perl with optional C code, no compiler needed
11787     +   - C++ and perl, a C++ compiler will be needed
11788     o   - perl and another language other than C or C++
11789
11790   I - Interface Style
11791     f   - plain Functions, no references used
11792     h   - hybrid, object and function interfaces available
11793     n   - no interface at all (huh?)
11794     r   - some use of unblessed References or ties
11795     O   - Object oriented using blessed references and/or inheritance
11796
11797   P - Public License
11798     p   - Standard-Perl: user may choose between GPL and Artistic
11799     g   - GPL: GNU General Public License
11800     l   - LGPL: "GNU Lesser General Public License" (previously known as
11801           "GNU Library General Public License")
11802     b   - BSD: The BSD License
11803     a   - Artistic license alone
11804     2   - Artistic license 2.0 or later
11805     o   - open source: appoved by www.opensource.org
11806     d   - allows distribution without restrictions
11807     r   - restricted distribtion
11808     n   - no license at all
11809
11810 =item CPAN::Module::force($method,@args)
11811
11812 Forces CPAN to perform a task that it normally would have refused to
11813 do. Force takes as arguments a method name to be called and any number
11814 of additional arguments that should be passed to the called method.
11815 The internals of the object get the needed changes so that CPAN.pm
11816 does not refuse to take the action. See also the section above on the
11817 C<force> and the C<fforce> pragma.
11818
11819 =item CPAN::Module::get()
11820
11821 Runs a get on the distribution associated with this module.
11822
11823 =item CPAN::Module::inst_file()
11824
11825 Returns the filename of the module found in @INC. The first file found
11826 is reported just like perl itself stops searching @INC when it finds a
11827 module.
11828
11829 =item CPAN::Module::available_file()
11830
11831 Returns the filename of the module found in PERL5LIB or @INC. The
11832 first file found is reported. The advantage of this method over
11833 C<inst_file> is that modules that have been tested but not yet
11834 installed are included because PERL5LIB keeps track of tested modules.
11835
11836 =item CPAN::Module::inst_version()
11837
11838 Returns the version number of the installed module in readable format.
11839
11840 =item CPAN::Module::available_version()
11841
11842 Returns the version number of the available module in readable format.
11843
11844 =item CPAN::Module::install()
11845
11846 Runs an C<install> on the distribution associated with this module.
11847
11848 =item CPAN::Module::look()
11849
11850 Changes to the directory where the distribution associated with this
11851 module has been unpacked and opens a subshell there. Exiting the
11852 subshell returns.
11853
11854 =item CPAN::Module::make()
11855
11856 Runs a C<make> on the distribution associated with this module.
11857
11858 =item CPAN::Module::manpage_headline()
11859
11860 If module is installed, peeks into the module's manpage, reads the
11861 headline and returns it. Moreover, if the module has been downloaded
11862 within this session, does the equivalent on the downloaded module even
11863 if it is not installed.
11864
11865 =item CPAN::Module::perldoc()
11866
11867 Runs a C<perldoc> on this module.
11868
11869 =item CPAN::Module::readme()
11870
11871 Runs a C<readme> on the distribution associated with this module.
11872
11873 =item CPAN::Module::reports()
11874
11875 Calls the reports() method on the associated distribution object.
11876
11877 =item CPAN::Module::test()
11878
11879 Runs a C<test> on the distribution associated with this module.
11880
11881 =item CPAN::Module::uptodate()
11882
11883 Returns 1 if the module is installed and up-to-date.
11884
11885 =item CPAN::Module::userid()
11886
11887 Returns the author's ID of the module.
11888
11889 =back
11890
11891 =head2 Cache Manager
11892
11893 Currently the cache manager only keeps track of the build directory
11894 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
11895 deletes complete directories below C<build_dir> as soon as the size of
11896 all directories there gets bigger than $CPAN::Config->{build_cache}
11897 (in MB). The contents of this cache may be used for later
11898 re-installations that you intend to do manually, but will never be
11899 trusted by CPAN itself. This is due to the fact that the user might
11900 use these directories for building modules on different architectures.
11901
11902 There is another directory ($CPAN::Config->{keep_source_where}) where
11903 the original distribution files are kept. This directory is not
11904 covered by the cache manager and must be controlled by the user. If
11905 you choose to have the same directory as build_dir and as
11906 keep_source_where directory, then your sources will be deleted with
11907 the same fifo mechanism.
11908
11909 =head2 Bundles
11910
11911 A bundle is just a perl module in the namespace Bundle:: that does not
11912 define any functions or methods. It usually only contains documentation.
11913
11914 It starts like a perl module with a package declaration and a $VERSION
11915 variable. After that the pod section looks like any other pod with the
11916 only difference being that I<one special pod section> exists starting with
11917 (verbatim):
11918
11919     =head1 CONTENTS
11920
11921 In this pod section each line obeys the format
11922
11923         Module_Name [Version_String] [- optional text]
11924
11925 The only required part is the first field, the name of a module
11926 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
11927 of the line is optional. The comment part is delimited by a dash just
11928 as in the man page header.
11929
11930 The distribution of a bundle should follow the same convention as
11931 other distributions.
11932
11933 Bundles are treated specially in the CPAN package. If you say 'install
11934 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
11935 the modules in the CONTENTS section of the pod. You can install your
11936 own Bundles locally by placing a conformant Bundle file somewhere into
11937 your @INC path. The autobundle() command which is available in the
11938 shell interface does that for you by including all currently installed
11939 modules in a snapshot bundle file.
11940
11941 =head1 PREREQUISITES
11942
11943 If you have a local mirror of CPAN and can access all files with
11944 "file:" URLs, then you only need a perl better than perl5.003 to run
11945 this module. Otherwise Net::FTP is strongly recommended. LWP may be
11946 required for non-UNIX systems or if your nearest CPAN site is
11947 associated with a URL that is not C<ftp:>.
11948
11949 If you have neither Net::FTP nor LWP, there is a fallback mechanism
11950 implemented for an external ftp command or for an external lynx
11951 command.
11952
11953 =head1 UTILITIES
11954
11955 =head2 Finding packages and VERSION
11956
11957 This module presumes that all packages on CPAN
11958
11959 =over 2
11960
11961 =item *
11962
11963 declare their $VERSION variable in an easy to parse manner. This
11964 prerequisite can hardly be relaxed because it consumes far too much
11965 memory to load all packages into the running program just to determine
11966 the $VERSION variable. Currently all programs that are dealing with
11967 version use something like this
11968
11969     perl -MExtUtils::MakeMaker -le \
11970         'print MM->parse_version(shift)' filename
11971
11972 If you are author of a package and wonder if your $VERSION can be
11973 parsed, please try the above method.
11974
11975 =item *
11976
11977 come as compressed or gzipped tarfiles or as zip files and contain a
11978 C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
11979 without much enthusiasm).
11980
11981 =back
11982
11983 =head2 Debugging
11984
11985 The debugging of this module is a bit complex, because we have
11986 interferences of the software producing the indices on CPAN, of the
11987 mirroring process on CPAN, of packaging, of configuration, of
11988 synchronicity, and of bugs within CPAN.pm.
11989
11990 For debugging the code of CPAN.pm itself in interactive mode some more
11991 or less useful debugging aid can be turned on for most packages within
11992 CPAN.pm with one of
11993
11994 =over 2
11995
11996 =item o debug package...
11997
11998 sets debug mode for packages.
11999
12000 =item o debug -package...
12001
12002 unsets debug mode for packages.
12003
12004 =item o debug all
12005
12006 turns debugging on for all packages.
12007
12008 =item o debug number
12009
12010 =back
12011
12012 which sets the debugging packages directly. Note that C<o debug 0>
12013 turns debugging off.
12014
12015 What seems quite a successful strategy is the combination of C<reload
12016 cpan> and the debugging switches. Add a new debug statement while
12017 running in the shell and then issue a C<reload cpan> and see the new
12018 debugging messages immediately without losing the current context.
12019
12020 C<o debug> without an argument lists the valid package names and the
12021 current set of packages in debugging mode. C<o debug> has built-in
12022 completion support.
12023
12024 For debugging of CPAN data there is the C<dump> command which takes
12025 the same arguments as make/test/install and outputs each object's
12026 Data::Dumper dump. If an argument looks like a perl variable and
12027 contains one of C<$>, C<@> or C<%>, it is eval()ed and fed to
12028 Data::Dumper directly.
12029
12030 =head2 Floppy, Zip, Offline Mode
12031
12032 CPAN.pm works nicely without network too. If you maintain machines
12033 that are not networked at all, you should consider working with file:
12034 URLs. Of course, you have to collect your modules somewhere first. So
12035 you might use CPAN.pm to put together all you need on a networked
12036 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
12037 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
12038 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
12039 with this floppy. See also below the paragraph about CD-ROM support.
12040
12041 =head2 Basic Utilities for Programmers
12042
12043 =over 2
12044
12045 =item has_inst($module)
12046
12047 Returns true if the module is installed. Used to load all modules into
12048 the running CPAN.pm which are considered optional. The config variable
12049 C<dontload_list> can be used to intercept the C<has_inst()> call such
12050 that an optional module is not loaded despite being available. For
12051 example the following command will prevent that C<YAML.pm> is being
12052 loaded:
12053
12054     cpan> o conf dontload_list push YAML
12055
12056 See the source for details.
12057
12058 =item has_usable($module)
12059
12060 Returns true if the module is installed and is in a usable state. Only
12061 useful for a handful of modules that are used internally. See the
12062 source for details.
12063
12064 =item instance($module)
12065
12066 The constructor for all the singletons used to represent modules,
12067 distributions, authors and bundles. If the object already exists, this
12068 method returns the object, otherwise it calls the constructor.
12069
12070 =back
12071
12072 =head1 SECURITY
12073
12074 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
12075 install foreign, unmasked, unsigned code on your machine. We compare
12076 to a checksum that comes from the net just as the distribution file
12077 itself. But we try to make it easy to add security on demand:
12078
12079 =head2 Cryptographically signed modules
12080
12081 Since release 1.77 CPAN.pm has been able to verify cryptographically
12082 signed module distributions using Module::Signature.  The CPAN modules
12083 can be signed by their authors, thus giving more security.  The simple
12084 unsigned MD5 checksums that were used before by CPAN protect mainly
12085 against accidental file corruption.
12086
12087 You will need to have Module::Signature installed, which in turn
12088 requires that you have at least one of Crypt::OpenPGP module or the
12089 command-line F<gpg> tool installed.
12090
12091 You will also need to be able to connect over the Internet to the public
12092 keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
12093
12094 The configuration parameter check_sigs is there to turn signature
12095 checking on or off.
12096
12097 =head1 EXPORT
12098
12099 Most functions in package CPAN are exported per default. The reason
12100 for this is that the primary use is intended for the cpan shell or for
12101 one-liners.
12102
12103 =head1 ENVIRONMENT
12104
12105 When the CPAN shell enters a subshell via the look command, it sets
12106 the environment CPAN_SHELL_LEVEL to 1 or increments it if it is
12107 already set.
12108
12109 When CPAN runs, it sets the environment variable PERL5_CPAN_IS_RUNNING
12110 to the ID of the running process. It also sets
12111 PERL5_CPANPLUS_IS_RUNNING to prevent runaway processes which could
12112 happen with older versions of Module::Install.
12113
12114 When running C<perl Makefile.PL>, the environment variable
12115 C<PERL5_CPAN_IS_EXECUTING> is set to the full path of the
12116 C<Makefile.PL> that is being executed. This prevents runaway processes
12117 with newer versions of Module::Install.
12118
12119 When the config variable ftp_passive is set, all downloads will be run
12120 with the environment variable FTP_PASSIVE set to this value. This is
12121 in general a good idea as it influences both Net::FTP and LWP based
12122 connections. The same effect can be achieved by starting the cpan
12123 shell with this environment variable set. For Net::FTP alone, one can
12124 also always set passive mode by running libnetcfg.
12125
12126 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
12127
12128 Populating a freshly installed perl with my favorite modules is pretty
12129 easy if you maintain a private bundle definition file. To get a useful
12130 blueprint of a bundle definition file, the command autobundle can be used
12131 on the CPAN shell command line. This command writes a bundle definition
12132 file for all modules that are installed for the currently running perl
12133 interpreter. It's recommended to run this command only once and from then
12134 on maintain the file manually under a private name, say
12135 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
12136
12137     cpan> install Bundle::my_bundle
12138
12139 then answer a few questions and then go out for a coffee.
12140
12141 Maintaining a bundle definition file means keeping track of two
12142 things: dependencies and interactivity. CPAN.pm sometimes fails on
12143 calculating dependencies because not all modules define all MakeMaker
12144 attributes correctly, so a bundle definition file should specify
12145 prerequisites as early as possible. On the other hand, it's a bit
12146 annoying that many distributions need some interactive configuring. So
12147 what I try to accomplish in my private bundle file is to have the
12148 packages that need to be configured early in the file and the gentle
12149 ones later, so I can go out after a few minutes and leave CPAN.pm
12150 untended.
12151
12152 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
12153
12154 Thanks to Graham Barr for contributing the following paragraphs about
12155 the interaction between perl, and various firewall configurations. For
12156 further information on firewalls, it is recommended to consult the
12157 documentation that comes with the ncftp program. If you are unable to
12158 go through the firewall with a simple Perl setup, it is very likely
12159 that you can configure ncftp so that it works for your firewall.
12160
12161 =head2 Three basic types of firewalls
12162
12163 Firewalls can be categorized into three basic types.
12164
12165 =over 4
12166
12167 =item http firewall
12168
12169 This is where the firewall machine runs a web server and to access the
12170 outside world you must do it via the web server. If you set environment
12171 variables like http_proxy or ftp_proxy to a values beginning with http://
12172 or in your web browser you have to set proxy information then you know
12173 you are running an http firewall.
12174
12175 To access servers outside these types of firewalls with perl (even for
12176 ftp) you will need to use LWP.
12177
12178 =item ftp firewall
12179
12180 This where the firewall machine runs an ftp server. This kind of
12181 firewall will only let you access ftp servers outside the firewall.
12182 This is usually done by connecting to the firewall with ftp, then
12183 entering a username like "user@outside.host.com"
12184
12185 To access servers outside these type of firewalls with perl you
12186 will need to use Net::FTP.
12187
12188 =item One way visibility
12189
12190 I say one way visibility as these firewalls try to make themselves look
12191 invisible to the users inside the firewall. An FTP data connection is
12192 normally created by sending the remote server your IP address and then
12193 listening for the connection. But the remote server will not be able to
12194 connect to you because of the firewall. So for these types of firewall
12195 FTP connections need to be done in a passive mode.
12196
12197 There are two that I can think off.
12198
12199 =over 4
12200
12201 =item SOCKS
12202
12203 If you are using a SOCKS firewall you will need to compile perl and link
12204 it with the SOCKS library, this is what is normally called a 'socksified'
12205 perl. With this executable you will be able to connect to servers outside
12206 the firewall as if it is not there.
12207
12208 =item IP Masquerade
12209
12210 This is the firewall implemented in the Linux kernel, it allows you to
12211 hide a complete network behind one IP address. With this firewall no
12212 special compiling is needed as you can access hosts directly.
12213
12214 For accessing ftp servers behind such firewalls you usually need to
12215 set the environment variable C<FTP_PASSIVE> or the config variable
12216 ftp_passive to a true value.
12217
12218 =back
12219
12220 =back
12221
12222 =head2 Configuring lynx or ncftp for going through a firewall
12223
12224 If you can go through your firewall with e.g. lynx, presumably with a
12225 command such as
12226
12227     /usr/local/bin/lynx -pscott:tiger
12228
12229 then you would configure CPAN.pm with the command
12230
12231     o conf lynx "/usr/local/bin/lynx -pscott:tiger"
12232
12233 That's all. Similarly for ncftp or ftp, you would configure something
12234 like
12235
12236     o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
12237
12238 Your mileage may vary...
12239
12240 =head1 FAQ
12241
12242 =over 4
12243
12244 =item 1)
12245
12246 I installed a new version of module X but CPAN keeps saying,
12247 I have the old version installed
12248
12249 Most probably you B<do> have the old version installed. This can
12250 happen if a module installs itself into a different directory in the
12251 @INC path than it was previously installed. This is not really a
12252 CPAN.pm problem, you would have the same problem when installing the
12253 module manually. The easiest way to prevent this behaviour is to add
12254 the argument C<UNINST=1> to the C<make install> call, and that is why
12255 many people add this argument permanently by configuring
12256
12257   o conf make_install_arg UNINST=1
12258
12259 =item 2)
12260
12261 So why is UNINST=1 not the default?
12262
12263 Because there are people who have their precise expectations about who
12264 may install where in the @INC path and who uses which @INC array. In
12265 fine tuned environments C<UNINST=1> can cause damage.
12266
12267 =item 3)
12268
12269 I want to clean up my mess, and install a new perl along with
12270 all modules I have. How do I go about it?
12271
12272 Run the autobundle command for your old perl and optionally rename the
12273 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
12274 with the Configure option prefix, e.g.
12275
12276     ./Configure -Dprefix=/usr/local/perl-5.6.78.9
12277
12278 Install the bundle file you produced in the first step with something like
12279
12280     cpan> install Bundle::mybundle
12281
12282 and you're done.
12283
12284 =item 4)
12285
12286 When I install bundles or multiple modules with one command
12287 there is too much output to keep track of.
12288
12289 You may want to configure something like
12290
12291   o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
12292   o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
12293
12294 so that STDOUT is captured in a file for later inspection.
12295
12296
12297 =item 5)
12298
12299 I am not root, how can I install a module in a personal directory?
12300
12301 First of all, you will want to use your own configuration, not the one
12302 that your root user installed. If you do not have permission to write
12303 in the cpan directory that root has configured, you will be asked if
12304 you want to create your own config. Answering "yes" will bring you into
12305 CPAN's configuration stage, using the system config for all defaults except
12306 things that have to do with CPAN's work directory, saving your choices to
12307 your MyConfig.pm file.
12308
12309 You can also manually initiate this process with the following command:
12310
12311     % perl -MCPAN -e 'mkmyconfig'
12312
12313 or by running
12314
12315     mkmyconfig
12316
12317 from the CPAN shell.
12318
12319 You will most probably also want to configure something like this:
12320
12321   o conf makepl_arg "LIB=~/myperl/lib \
12322                     INSTALLMAN1DIR=~/myperl/man/man1 \
12323                     INSTALLMAN3DIR=~/myperl/man/man3 \
12324                     INSTALLSCRIPT=~/myperl/bin \
12325                     INSTALLBIN=~/myperl/bin"
12326
12327 and then (oh joy) the equivalent command for Module::Build. That would
12328 be
12329
12330   o conf mbuildpl_arg "--lib=~/myperl/lib \
12331                     --installman1dir=~/myperl/man/man1 \
12332                     --installman3dir=~/myperl/man/man3 \
12333                     --installscript=~/myperl/bin \
12334                     --installbin=~/myperl/bin"
12335
12336 You can make this setting permanent like all C<o conf> settings with
12337 C<o conf commit> or by setting C<auto_commit> beforehand.
12338
12339 You will have to add ~/myperl/man to the MANPATH environment variable
12340 and also tell your perl programs to look into ~/myperl/lib, e.g. by
12341 including
12342
12343   use lib "$ENV{HOME}/myperl/lib";
12344
12345 or setting the PERL5LIB environment variable.
12346
12347 While we're speaking about $ENV{HOME}, it might be worth mentioning,
12348 that for Windows we use the File::HomeDir module that provides an
12349 equivalent to the concept of the home directory on Unix.
12350
12351 Another thing you should bear in mind is that the UNINST parameter can
12352 be dangerous when you are installing into a private area because you
12353 might accidentally remove modules that other people depend on that are
12354 not using the private area.
12355
12356 =item 6)
12357
12358 How to get a package, unwrap it, and make a change before building it?
12359
12360 Have a look at the C<look> (!) command.
12361
12362 =item 7)
12363
12364 I installed a Bundle and had a couple of fails. When I
12365 retried, everything resolved nicely. Can this be fixed to work
12366 on first try?
12367
12368 The reason for this is that CPAN does not know the dependencies of all
12369 modules when it starts out. To decide about the additional items to
12370 install, it just uses data found in the META.yml file or the generated
12371 Makefile. An undetected missing piece breaks the process. But it may
12372 well be that your Bundle installs some prerequisite later than some
12373 depending item and thus your second try is able to resolve everything.
12374 Please note, CPAN.pm does not know the dependency tree in advance and
12375 cannot sort the queue of things to install in a topologically correct
12376 order. It resolves perfectly well IF all modules declare the
12377 prerequisites correctly with the PREREQ_PM attribute to MakeMaker or
12378 the C<requires> stanza of Module::Build. For bundles which fail and
12379 you need to install often, it is recommended to sort the Bundle
12380 definition file manually.
12381
12382 =item 8)
12383
12384 In our intranet we have many modules for internal use. How
12385 can I integrate these modules with CPAN.pm but without uploading
12386 the modules to CPAN?
12387
12388 Have a look at the CPAN::Site module.
12389
12390 =item 9)
12391
12392 When I run CPAN's shell, I get an error message about things in my
12393 /etc/inputrc (or ~/.inputrc) file.
12394
12395 These are readline issues and can only be fixed by studying readline
12396 configuration on your architecture and adjusting the referenced file
12397 accordingly. Please make a backup of the /etc/inputrc or ~/.inputrc
12398 and edit them. Quite often harmless changes like uppercasing or
12399 lowercasing some arguments solves the problem.
12400
12401 =item 10)
12402
12403 Some authors have strange characters in their names.
12404
12405 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
12406 expecting ISO-8859-1 charset, a converter can be activated by setting
12407 term_is_latin to a true value in your config file. One way of doing so
12408 would be
12409
12410     cpan> o conf term_is_latin 1
12411
12412 If other charset support is needed, please file a bugreport against
12413 CPAN.pm at rt.cpan.org and describe your needs. Maybe we can extend
12414 the support or maybe UTF-8 terminals become widely available.
12415
12416 Note: this config variable is deprecated and will be removed in a
12417 future version of CPAN.pm. It will be replaced with the conventions
12418 around the family of $LANG and $LC_* environment variables.
12419
12420 =item 11)
12421
12422 When an install fails for some reason and then I correct the error
12423 condition and retry, CPAN.pm refuses to install the module, saying
12424 C<Already tried without success>.
12425
12426 Use the force pragma like so
12427
12428   force install Foo::Bar
12429
12430 Or you can use
12431
12432   look Foo::Bar
12433
12434 and then 'make install' directly in the subshell.
12435
12436 =item 12)
12437
12438 How do I install a "DEVELOPER RELEASE" of a module?
12439
12440 By default, CPAN will install the latest non-developer release of a
12441 module. If you want to install a dev release, you have to specify the
12442 partial path starting with the author id to the tarball you wish to
12443 install, like so:
12444
12445     cpan> install KWILLIAMS/Module-Build-0.27_07.tar.gz
12446
12447 Note that you can use the C<ls> command to get this path listed.
12448
12449 =item 13)
12450
12451 How do I install a module and all its dependencies from the commandline,
12452 without being prompted for anything, despite my CPAN configuration
12453 (or lack thereof)?
12454
12455 CPAN uses ExtUtils::MakeMaker's prompt() function to ask its questions, so
12456 if you set the PERL_MM_USE_DEFAULT environment variable, you shouldn't be
12457 asked any questions at all (assuming the modules you are installing are
12458 nice about obeying that variable as well):
12459
12460     % PERL_MM_USE_DEFAULT=1 perl -MCPAN -e 'install My::Module'
12461
12462 =item 14)
12463
12464 How do I create a Module::Build based Build.PL derived from an
12465 ExtUtils::MakeMaker focused Makefile.PL?
12466
12467 http://search.cpan.org/search?query=Module::Build::Convert
12468
12469 http://www.refcnt.org/papers/module-build-convert
12470
12471 =item 15)
12472
12473 What's the best CPAN site for me?
12474
12475 The urllist config parameter is yours. You can add and remove sites at
12476 will. You should find out which sites have the best uptodateness,
12477 bandwidth, reliability, etc. and are topologically close to you. Some
12478 people prefer fast downloads, others uptodateness, others reliability.
12479 You decide which to try in which order.
12480
12481 Henk P. Penning maintains a site that collects data about CPAN sites:
12482
12483   http://www.cs.uu.nl/people/henkp/mirmon/cpan.html
12484
12485 =item 16)
12486
12487 Why do I get asked the same questions every time I start the shell?
12488
12489 You can make your configuration changes permanent by calling the
12490 command C<o conf commit>. Alternatively set the C<auto_commit>
12491 variable to true by running C<o conf init auto_commit> and answering
12492 the following question with yes.
12493
12494 =back
12495
12496 =head1 COMPATIBILITY
12497
12498 =head2 OLD PERL VERSIONS
12499
12500 CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted
12501 newer versions. It is getting more and more difficult to get the
12502 minimal prerequisites working on older perls. It is close to
12503 impossible to get the whole Bundle::CPAN working there. If you're in
12504 the position to have only these old versions, be advised that CPAN is
12505 designed to work fine without the Bundle::CPAN installed.
12506
12507 To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is
12508 compatible with ancient perls and that File::Temp is listed as a
12509 prerequisite but CPAN has reasonable workarounds if it is missing.
12510
12511 =head2 CPANPLUS
12512
12513 This module and its competitor, the CPANPLUS module, are both much
12514 cooler than the other. CPAN.pm is older. CPANPLUS was designed to be
12515 more modular but it was never tried to make it compatible with CPAN.pm.
12516
12517 =head1 SECURITY ADVICE
12518
12519 This software enables you to upgrade software on your computer and so
12520 is inherently dangerous because the newly installed software may
12521 contain bugs and may alter the way your computer works or even make it
12522 unusable. Please consider backing up your data before every upgrade.
12523
12524 =head1 BUGS
12525
12526 Please report bugs via http://rt.cpan.org/
12527
12528 Before submitting a bug, please make sure that the traditional method
12529 of building a Perl module package from a shell by following the
12530 installation instructions of that package still works in your
12531 environment.
12532
12533 =head1 AUTHOR
12534
12535 Andreas Koenig C<< <andk@cpan.org> >>
12536
12537 =head1 LICENSE
12538
12539 This program is free software; you can redistribute it and/or
12540 modify it under the same terms as Perl itself.
12541
12542 See L<http://www.perl.com/perl/misc/Artistic.html>
12543
12544 =head1 TRANSLATIONS
12545
12546 Kawai,Takanori provides a Japanese translation of this manpage at
12547 http://homepage3.nifty.com/hippo2000/perltips/CPAN.htm
12548
12549 =head1 SEE ALSO
12550
12551 cpan(1), CPAN::Nox(3pm), CPAN::Version(3pm)
12552
12553 =cut
12554
12555