lib/CPAN.pm

   1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
   2 use strict;
   3 package CPAN;
   4 $CPAN::VERSION = '1.88_79';
   5 $CPAN::VERSION = eval $CPAN::VERSION;
   6
   7 use CPAN::HandleConfig;
   8 use CPAN::Version;
   9 use CPAN::Debug;
  10 use CPAN::Queue;
  11 use CPAN::Tarzip;
  12 use Carp ();
  13 use Config ();
  14 use Cwd ();
  15 use DirHandle ();
  16 use Exporter ();
  17 use ExtUtils::MakeMaker qw(prompt); # for some unknown reason,
  18                                     # 5.005_04 does not work without
  19                                     # this
  20 use File::Basename ();
  21 use File::Copy ();
  22 use File::Find;
  23 use File::Path ();
  24 use File::Spec ();
  25 use FileHandle ();
  26 use Fcntl qw(:flock);
  27 use Safe ();
  28 use Sys::Hostname qw(hostname);
  29 use Text::ParseWords ();
  30 use Text::Wrap ();
  31
  32 # we need to run chdir all over and we would get at wrong libraries
  33 # there
  34 BEGIN {
  35     if (File::Spec->can("rel2abs")) {
  36         for my $inc (@INC) {
  37             $inc = File::Spec->rel2abs($inc) unless ref $inc;
  38         }
  39     }
  40 }
  41 no lib ".";
  42
  43 require Mac::BuildTools if $^O eq 'MacOS';
  44 $ENV{PERL5_CPAN_IS_RUNNING}=1;
  45 $ENV{PERL5_CPANPLUS_IS_RUNNING}=1; # https://rt.cpan.org/Ticket/Display.html?id=23735
  46
  47 END { $CPAN::End++; &cleanup; }
  48
  49 $CPAN::Signal ||= 0;
  50 $CPAN::Frontend ||= "CPAN::Shell";
  51 unless (@CPAN::Defaultsites){
  52     @CPAN::Defaultsites = map {
  53         CPAN::URL->new(TEXT => $_, FROM => "DEF")
  54     }
  55         "http://www.perl.org/CPAN/",
  56             "ftp://ftp.perl.org/pub/CPAN/";
  57 }
  58 # $CPAN::iCwd (i for initial) is going to be initialized during find_perl
  59 $CPAN::Perl ||= CPAN::find_perl();
  60 $CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?";
  61 $CPAN::Defaultrecent ||= "http://search.cpan.org/recent";
  62
  63 # our globals are getting a mess
  64 use vars qw(
  65             $AUTOLOAD
  66             $Be_Silent
  67             $CONFIG_DIRTY
  68             $Defaultdocs
  69             $Defaultrecent
  70             $Echo_readline
  71             $Frontend
  72             $GOTOSHELL
  73             $HAS_USABLE
  74             $Have_warned
  75             $MAX_RECURSION
  76             $META
  77             $RUN_DEGRADED
  78             $Signal
  79             $SQLite
  80             $Suppress_readline
  81             $VERSION
  82             $autoload_recursion
  83             $term
  84             @Defaultsites
  85             @EXPORT
  86            );
  87
  88 $MAX_RECURSION = 32;
  89
  90 @CPAN::ISA = qw(CPAN::Debug Exporter);
  91
  92 # note that these functions live in CPAN::Shell and get executed via
  93 # AUTOLOAD when called directly
  94 @EXPORT = qw(
  95              autobundle
  96              bundle
  97              clean
  98              cvs_import
  99              expand
 100              force
 101              fforce
 102              get
 103              install
 104              install_tested
 105              is_tested
 106              make
 107              mkmyconfig
 108              notest
 109              perldoc
 110              readme
 111              recent
 112              recompile
 113              report
 114              shell
 115              test
 116              upgrade
 117             );
 118
 119 sub soft_chdir_with_alternatives ($);
 120
 121 {
 122     $autoload_recursion ||= 0;
 123
 124     #-> sub CPAN::AUTOLOAD ;
 125     sub AUTOLOAD {
 126         $autoload_recursion++;
 127         my($l) = $AUTOLOAD;
 128         $l =~ s/.*:://;
 129         if ($CPAN::Signal) {
 130             warn "Refusing to autoload '$l' while signal pending";
 131             $autoload_recursion--;
 132             return;
 133         }
 134         if ($autoload_recursion > 1) {
 135             my $fullcommand = join " ", map { "'$_'" } $l, @_;
 136             warn "Refusing to autoload $fullcommand in recursion\n";
 137             $autoload_recursion--;
 138             return;
 139         }
 140         my(%export);
 141         @export{@EXPORT} = '';
 142         CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 143         if (exists $export{$l}){
 144             CPAN::Shell->$l(@_);
 145         } else {
 146             die(qq{Unknown CPAN command "$AUTOLOAD". }.
 147                 qq{Type ? for help.\n});
 148         }
 149         $autoload_recursion--;
 150     }
 151 }
 152
 153 #-> sub CPAN::shell ;
 154 sub shell {
 155     my($self) = @_;
 156     $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
 157     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 158
 159     my $oprompt = shift || CPAN::Prompt->new;
 160     my $prompt = $oprompt;
 161     my $commandline = shift || "";
 162     $CPAN::CurrentCommandId ||= 1;
 163
 164     local($^W) = 1;
 165     unless ($Suppress_readline) {
 166         require Term::ReadLine;
 167         if (! $term
 168             or
 169             $term->ReadLine eq "Term::ReadLine::Stub"
 170            ) {
 171             $term = Term::ReadLine->new('CPAN Monitor');
 172         }
 173         if ($term->ReadLine eq "Term::ReadLine::Gnu") {
 174             my $attribs = $term->Attribs;
 175              $attribs->{attempted_completion_function} = sub {
 176                  &CPAN::Complete::gnu_cpl;
 177              }
 178         } else {
 179             $readline::rl_completion_function =
 180                 $readline::rl_completion_function = 'CPAN::Complete::cpl';
 181         }
 182         if (my $histfile = $CPAN::Config->{'histfile'}) {{
 183             unless ($term->can("AddHistory")) {
 184                 $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
 185                 last;
 186             }
 187             $META->readhist($term,$histfile);
 188         }}
 189         for ($CPAN::Config->{term_ornaments}) { # alias
 190             local $Term::ReadLine::termcap_nowarn = 1;
 191             $term->ornaments($_) if defined;
 192         }
 193         # $term->OUT is autoflushed anyway
 194         my $odef = select STDERR;
 195         $| = 1;
 196         select STDOUT;
 197         $| = 1;
 198         select $odef;
 199     }
 200
 201     $META->checklock();
 202     my @cwd = grep { defined $_ and length $_ }
 203         CPAN::anycwd(),
 204               File::Spec->can("tmpdir") ? File::Spec->tmpdir() : (),
 205                     File::Spec->rootdir();
 206     my $try_detect_readline;
 207     $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
 208     my $rl_avail = $Suppress_readline ? "suppressed" :
 209         ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
 210             "available (try 'install Bundle::CPAN')";
 211
 212     unless ($CPAN::Config->{'inhibit_startup_message'}){
 213         $CPAN::Frontend->myprint(
 214                                  sprintf qq{
 215 cpan shell -- CPAN exploration and modules installation (v%s)
 216 ReadLine support %s
 217
 218 },
 219                                  $CPAN::VERSION,
 220                                  $rl_avail
 221                                 )
 222     }
 223     my($continuation) = "";
 224     my $last_term_ornaments;
 225   SHELLCOMMAND: while () {
 226         if ($Suppress_readline) {
 227             if ($Echo_readline) {
 228                 $|=1;
 229             }
 230             print $prompt;
 231             last SHELLCOMMAND unless defined ($_ = <> );
 232             if ($Echo_readline) {
 233                 # backdoor: I could not find a way to record sessions
 234                 print $_;
 235             }
 236             chomp;
 237         } else {
 238             last SHELLCOMMAND unless
 239                 defined ($_ = $term->readline($prompt, $commandline));
 240         }
 241         $_ = "$continuation$_" if $continuation;
 242         s/^\s+//;
 243         next SHELLCOMMAND if /^$/;
 244         $_ = 'h' if /^\s*\?/;
 245         if (/^(?:q(?:uit)?|bye|exit)$/i) {
 246             last SHELLCOMMAND;
 247         } elsif (s/\\$//s) {
 248             chomp;
 249             $continuation = $_;
 250             $prompt = "    > ";
 251         } elsif (/^\!/) {
 252             s/^\!//;
 253             my($eval) = $_;
 254             package CPAN::Eval;
 255             use strict;
 256             use vars qw($import_done);
 257             CPAN->import(':DEFAULT') unless $import_done++;
 258             CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
 259             eval($eval);
 260             warn $@ if $@;
 261             $continuation = "";
 262             $prompt = $oprompt;
 263         } elsif (/./) {
 264             my(@line);
 265             eval { @line = Text::ParseWords::shellwords($_) };
 266             warn($@), next SHELLCOMMAND if $@;
 267             warn("Text::Parsewords could not parse the line [$_]"),
 268                 next SHELLCOMMAND unless @line;
 269             $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
 270             my $command = shift @line;
 271             eval { CPAN::Shell->$command(@line) };
 272             if ($@ && "$@" =~ /\S/){
 273                 require Carp;
 274                 Carp::cluck("Catching error: '$@'");
 275             }
 276             if ($command =~ /^(make|test|install|ff?orce|notest|clean|report|upgrade)$/) {
 277                 CPAN::Shell->failed($CPAN::CurrentCommandId,1);
 278             }
 279             soft_chdir_with_alternatives(\@cwd);
 280             $CPAN::Frontend->myprint("\n");
 281             $continuation = "";
 282             $CPAN::CurrentCommandId++;
 283             $prompt = $oprompt;
 284         }
 285     } continue {
 286       $commandline = ""; # I do want to be able to pass a default to
 287                          # shell, but on the second command I see no
 288                          # use in that
 289       $Signal=0;
 290       CPAN::Queue->nullify_queue;
 291       if ($try_detect_readline) {
 292         if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
 293             ||
 294             $CPAN::META->has_inst("Term::ReadLine::Perl")
 295            ) {
 296             delete $INC{"Term/ReadLine.pm"};
 297             my $redef = 0;
 298             local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
 299             require Term::ReadLine;
 300             $CPAN::Frontend->myprint("\n$redef subroutines in ".
 301                                      "Term::ReadLine redefined\n");
 302             $GOTOSHELL = 1;
 303         }
 304       }
 305       if ($term and $term->can("ornaments")) {
 306           for ($CPAN::Config->{term_ornaments}) { # alias
 307               if (defined $_) {
 308                   if (not defined $last_term_ornaments
 309                       or $_ != $last_term_ornaments
 310                      ) {
 311                       local $Term::ReadLine::termcap_nowarn = 1;
 312                       $term->ornaments($_);
 313                       $last_term_ornaments = $_;
 314                   }
 315               } else {
 316                   undef $last_term_ornaments;
 317               }
 318           }
 319       }
 320       for my $class (qw(Module Distribution)) {
 321           # again unsafe meta access?
 322           for my $dm (keys %{$CPAN::META->{readwrite}{"CPAN::$class"}}) {
 323               next unless $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
 324               CPAN->debug("BUG: $class '$dm' was in command state, resetting");
 325               delete $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
 326           }
 327       }
 328       if ($GOTOSHELL) {
 329           $GOTOSHELL = 0; # not too often
 330           $META->savehist if $CPAN::term && $CPAN::term->can("GetHistory");
 331           @_ = ($oprompt,"");
 332           goto &shell;
 333       }
 334     }
 335     soft_chdir_with_alternatives(\@cwd);
 336 }
 337
 338 sub soft_chdir_with_alternatives ($) {
 339     my($cwd) = @_;
 340     unless (@$cwd) {
 341         my $root = File::Spec->rootdir();
 342         $CPAN::Frontend->mywarn(qq{Warning: no good directory to chdir to!
 343 Trying '$root' as temporary haven.
 344 });
 345         push @$cwd, $root;
 346     }
 347     while () {
 348         if (chdir $cwd->[0]) {
 349             return;
 350         } else {
 351             if (@$cwd>1) {
 352                 $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $!
 353 Trying to chdir to "$cwd->[1]" instead.
 354 });
 355                 shift @$cwd;
 356             } else {
 357                 $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!});
 358             }
 359         }
 360     }
 361 }
 362
 363 sub _yaml_module () {
 364     my $yaml_module = $CPAN::Config->{yaml_module} || "YAML";
 365     if (
 366         $yaml_module ne "YAML"
 367         &&
 368         !$CPAN::META->has_inst($yaml_module)
 369        ) {
 370         # $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back to 'YAML'\n");
 371         $yaml_module = "YAML";
 372     }
 373     if ($yaml_module eq "YAML"
 374         &&
 375         $CPAN::META->has_inst($yaml_module)
 376         &&
 377         $YAML::VERSION < 0.60
 378         &&
 379         !$Have_warned->{"YAML"}++
 380        ) {
 381         $CPAN::Frontend->mywarn("Warning: YAML version '$YAML::VERSION' is too low, please upgrade!\n".
 382                                 "I'll continue but problems are *very* likely to happen.\n"
 383                                );
 384         $CPAN::Frontend->mysleep(5);
 385     }
 386     return $yaml_module;
 387 }
 388
 389 # CPAN::_yaml_loadfile
 390 sub _yaml_loadfile {
 391     my($self,$local_file) = @_;
 392     return +[] unless -s $local_file;
 393     my $yaml_module = _yaml_module;
 394     if ($CPAN::META->has_inst($yaml_module)) {
 395         my $code;
 396         if ($code = UNIVERSAL::can($yaml_module, "LoadFile")) {
 397             my @yaml;
 398             eval { @yaml = $code->($local_file); };
 399             if ($@) {
 400                 # this shall not be done by the frontend
 401                 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
 402             }
 403             return \@yaml;
 404         } elsif ($code = UNIVERSAL::can($yaml_module, "Load")) {
 405             local *FH;
 406             open FH, $local_file or die "Could not open '$local_file': $!";
 407             local $/;
 408             my $ystream = <FH>;
 409             my @yaml;
 410             eval { @yaml = $code->($ystream); };
 411             if ($@) {
 412                 # this shall not be done by the frontend
 413                 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
 414             }
 415             return \@yaml;
 416         }
 417     } else {
 418         # this shall not be done by the frontend
 419         die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "parse");
 420     }
 421     return +[];
 422 }
 423
 424 # CPAN::_yaml_dumpfile
 425 sub _yaml_dumpfile {
 426     my($self,$local_file,@what) = @_;
 427     my $yaml_module = _yaml_module;
 428     if ($CPAN::META->has_inst($yaml_module)) {
 429         my $code;
 430         if (UNIVERSAL::isa($local_file, "FileHandle")) {
 431             $code = UNIVERSAL::can($yaml_module, "Dump");
 432             eval { print $local_file $code->(@what) };
 433         } elsif ($code = UNIVERSAL::can($yaml_module, "DumpFile")) {
 434             eval { $code->($local_file,@what); };
 435         } elsif ($code = UNIVERSAL::can($yaml_module, "Dump")) {
 436             local *FH;
 437             open FH, ">$local_file" or die "Could not open '$local_file': $!";
 438             print FH $code->(@what);
 439         }
 440         if ($@) {
 441             die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"dump",$@);
 442         }
 443     } else {
 444         if (UNIVERSAL::isa($local_file, "FileHandle")) {
 445             # I think this case does not justify a warning at all
 446         } else {
 447             die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "dump");
 448         }
 449     }
 450 }
 451
 452 sub _init_sqlite () {
 453     unless ($CPAN::META->has_inst("CPAN::SQLite")) {
 454         $CPAN::Frontend->mywarn(qq{CPAN::SQLite not installed, trying to work without\n})
 455             unless $Have_warned->{"CPAN::SQLite"}++;
 456         return;
 457     }
 458     require CPAN::SQLite::META; # not needed since CVS version of 2006-12-17
 459     $CPAN::SQLite ||= CPAN::SQLite::META->new($CPAN::META);
 460 }
 461
 462 {
 463     my $negative_cache = {};
 464     sub _sqlite_running {
 465         if ($negative_cache->{time} && time < $negative_cache->{time} + 60) {
 466             # need to cache the result, otherwise too slow
 467             return $negative_cache->{fact};
 468         } else {
 469             $negative_cache = {}; # reset
 470         }
 471         my $ret = $CPAN::Config->{use_sqlite} && ($CPAN::SQLite || _init_sqlite());
 472         return $ret if $ret; # fast anyway
 473         $negative_cache->{time} = time;
 474         return $negative_cache->{fact} = $ret;
 475     }
 476 }
 477
 478 package CPAN::CacheMgr;
 479 use strict;
 480 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
 481 use File::Find;
 482
 483 package CPAN::FTP;
 484 use strict;
 485 use Fcntl qw(:flock);
 486 use vars qw($Ua $Thesite $ThesiteURL $Themethod);
 487 @CPAN::FTP::ISA = qw(CPAN::Debug);
 488
 489 package CPAN::LWP::UserAgent;
 490 use strict;
 491 use vars qw(@ISA $USER $PASSWD $SETUPDONE);
 492 # we delay requiring LWP::UserAgent and setting up inheritance until we need it
 493
 494 package CPAN::Complete;
 495 use strict;
 496 @CPAN::Complete::ISA = qw(CPAN::Debug);
 497 # Q: where is the "How do I add a new command" HOWTO?
 498 # A: svn diff -r 1048:1049 where andk added the report command
 499 @CPAN::Complete::COMMANDS = sort qw(
 500                                     ! a b d h i m o q r u
 501                                     autobundle
 502                                     clean
 503                                     cvs_import
 504                                     dump
 505                                     failed
 506                                     force
 507                                     fforce
 508                                     hosts
 509                                     install
 510                                     install_tested
 511                                     is_tested
 512                                     look
 513                                     ls
 514                                     make
 515                                     mkmyconfig
 516                                     notest
 517                                     perldoc
 518                                     readme
 519                                     recent
 520                                     recompile
 521                                     reload
 522                                     report
 523                                     scripts
 524                                     test
 525                                     upgrade
 526 );
 527
 528 package CPAN::Index;
 529 use strict;
 530 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED);
 531 @CPAN::Index::ISA = qw(CPAN::Debug);
 532 $LAST_TIME ||= 0;
 533 $DATE_OF_03 ||= 0;
 534 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
 535 sub PROTOCOL { 2.0 }
 536
 537 package CPAN::InfoObj;
 538 use strict;
 539 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
 540
 541 package CPAN::Author;
 542 use strict;
 543 @CPAN::Author::ISA = qw(CPAN::InfoObj);
 544
 545 package CPAN::Distribution;
 546 use strict;
 547 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
 548
 549 package CPAN::Bundle;
 550 use strict;
 551 @CPAN::Bundle::ISA = qw(CPAN::Module);
 552
 553 package CPAN::Module;
 554 use strict;
 555 @CPAN::Module::ISA = qw(CPAN::InfoObj);
 556
 557 package CPAN::Exception::RecursiveDependency;
 558 use strict;
 559 use overload '""' => "as_string";
 560
 561 # a module sees its distribution (no version)
 562 # a distribution sees its prereqs (which are module names) (usually with versions)
 563 # a bundle sees its module names and/or its distributions (no version)
 564
 565 sub new {
 566     my($class) = shift;
 567     my($deps) = shift;
 568     my (@deps,%seen,$loop_starts_with);
 569   DCHAIN: for my $dep (@$deps) {
 570         push @deps, {name => $dep, display_as => $dep};
 571         if ($seen{$dep}++){
 572             $loop_starts_with = $dep;
 573             last DCHAIN;
 574         }
 575     }
 576     my $in_loop = 0;
 577     for my $i (0..$#deps) {
 578         my $x = $deps[$i]{name};
 579         $in_loop ||= $x eq $loop_starts_with;
 580         my $xo = CPAN::Shell->expandany($x) or next;
 581         if ($xo->isa("CPAN::Module")) {
 582             my $have = $xo->inst_version || "N/A";
 583             my($want,$d,$want_type);
 584             if ($i>0 and $d = $deps[$i-1]{name}) {
 585                 my $do = CPAN::Shell->expandany($d);
 586                 $want = $do->{prereq_pm}{requires}{$x};
 587                 if (defined $want) {
 588                     $want_type = "requires: ";
 589                 } else {
 590                     $want = $do->{prereq_pm}{build_requires}{$x};
 591                     if (defined $want) {
 592                         $want_type = "build_requires: ";
 593                     } else {
 594                         $want_type = "unknown status";
 595                         $want = "???";
 596                     }
 597                 }
 598             } else {
 599                 $want = $xo->cpan_version;
 600                 $want_type = "want: ";
 601             }
 602             $deps[$i]{have} = $have;
 603             $deps[$i]{want_type} = $want_type;
 604             $deps[$i]{want} = $want;
 605             $deps[$i]{display_as} = "$x (have: $have; $want_type$want)";
 606         } elsif ($xo->isa("CPAN::Distribution")) {
 607             $deps[$i]{display_as} = $xo->pretty_id;
 608             if ($in_loop) {
 609                 $xo->{make} = CPAN::Distrostatus->new("NO cannot resolve circular dependency");
 610             } else {
 611                 $xo->{make} = CPAN::Distrostatus->new("NO one dependency ($loop_starts_with) is a circular dependency");
 612             }
 613             $xo->store_persistent_state; # otherwise I will not reach
 614                                          # all involved parties for
 615                                          # the next session
 616         }
 617     }
 618     bless { deps => \@deps }, $class;
 619 }
 620
 621 sub as_string {
 622     my($self) = shift;
 623     my $ret = "\nRecursive dependency detected:\n    ";
 624     $ret .= join("\n => ", map {$_->{display_as}} @{$self->{deps}});
 625     $ret .= ".\nCannot resolve.\n";
 626     $ret;
 627 }
 628
 629 package CPAN::Exception::yaml_not_installed;
 630 use strict;
 631 use overload '""' => "as_string";
 632
 633 sub new {
 634     my($class,$module,$file,$during) = @_;
 635     bless { module => $module, file => $file, during => $during }, $class;
 636 }
 637
 638 sub as_string {
 639     my($self) = shift;
 640     "'$self->{module}' not installed, cannot $self->{during} '$self->{file}'\n";
 641 }
 642
 643 package CPAN::Exception::yaml_process_error;
 644 use strict;
 645 use overload '""' => "as_string";
 646
 647 sub new {
 648     my($class,$module,$file,$during,$error) = shift;
 649     bless { module => $module,
 650             file => $file,
 651             during => $during,
 652             error => $error }, $class;
 653 }
 654
 655 sub as_string {
 656     my($self) = shift;
 657     "Alert: While trying to $self->{during} YAML file\n".
 658         "  $self->{file}\n".
 659             "with '$self->{module}' the following error was encountered:\n".
 660                 "  $self->{error}\n";
 661 }
 662
 663 package CPAN::Prompt; use overload '""' => "as_string";
 664 use vars qw($prompt);
 665 $prompt = "cpan> ";
 666 $CPAN::CurrentCommandId ||= 0;
 667 sub new {
 668     bless {}, shift;
 669 }
 670 sub as_string {
 671     my $word = "cpan";
 672     unless ($CPAN::META->{LOCK}) {
 673         $word = "nolock_cpan";
 674     }
 675     if ($CPAN::Config->{commandnumber_in_prompt}) {
 676         sprintf "$word\[%d]> ", $CPAN::CurrentCommandId;
 677     } else {
 678         "$word> ";
 679     }
 680 }
 681
 682 package CPAN::URL; use overload '""' => "as_string", fallback => 1;
 683 # accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist),
 684 # planned are things like age or quality
 685 sub new {
 686     my($class,%args) = @_;
 687     bless {
 688            %args
 689           }, $class;
 690 }
 691 sub as_string {
 692     my($self) = @_;
 693     $self->text;
 694 }
 695 sub text {
 696     my($self,$set) = @_;
 697     if (defined $set) {
 698         $self->{TEXT} = $set;
 699     }
 700     $self->{TEXT};
 701 }
 702
 703 package CPAN::Distrostatus;
 704 use overload '""' => "as_string",
 705     fallback => 1;
 706 sub new {
 707     my($class,$arg) = @_;
 708     bless {
 709            TEXT => $arg,
 710            FAILED => substr($arg,0,2) eq "NO",
 711            COMMANDID => $CPAN::CurrentCommandId,
 712            TIME => time,
 713           }, $class;
 714 }
 715 sub commandid { shift->{COMMANDID} }
 716 sub failed { shift->{FAILED} }
 717 sub text {
 718     my($self,$set) = @_;
 719     if (defined $set) {
 720         $self->{TEXT} = $set;
 721     }
 722     $self->{TEXT};
 723 }
 724 sub as_string {
 725     my($self) = @_;
 726     $self->text;
 727 }
 728
 729 package CPAN::Shell;
 730 use strict;
 731 use vars qw(
 732             $ADVANCED_QUERY
 733             $AUTOLOAD
 734             $COLOR_REGISTERED
 735             $autoload_recursion
 736             $reload
 737             @ISA
 738            );
 739 @CPAN::Shell::ISA = qw(CPAN::Debug);
 740 $COLOR_REGISTERED ||= 0;
 741
 742 {
 743     $autoload_recursion   ||= 0;
 744
 745     #-> sub CPAN::Shell::AUTOLOAD ;
 746     sub AUTOLOAD {
 747         $autoload_recursion++;
 748         my($l) = $AUTOLOAD;
 749         my $class = shift(@_);
 750         # warn "autoload[$l] class[$class]";
 751         $l =~ s/.*:://;
 752         if ($CPAN::Signal) {
 753             warn "Refusing to autoload '$l' while signal pending";
 754             $autoload_recursion--;
 755             return;
 756         }
 757         if ($autoload_recursion > 1) {
 758             my $fullcommand = join " ", map { "'$_'" } $l, @_;
 759             warn "Refusing to autoload $fullcommand in recursion\n";
 760             $autoload_recursion--;
 761             return;
 762         }
 763         if ($l =~ /^w/) {
 764             # XXX needs to be reconsidered
 765             if ($CPAN::META->has_inst('CPAN::WAIT')) {
 766                 CPAN::WAIT->$l(@_);
 767             } else {
 768                 $CPAN::Frontend->mywarn(qq{
 769 Commands starting with "w" require CPAN::WAIT to be installed.
 770 Please consider installing CPAN::WAIT to use the fulltext index.
 771 For this you just need to type
 772     install CPAN::WAIT
 773 });
 774             }
 775         } else {
 776             $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }.
 777                                     qq{Type ? for help.
 778 });
 779         }
 780         $autoload_recursion--;
 781     }
 782 }
 783
 784 package CPAN;
 785 use strict;
 786
 787 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
 788
 789 # from here on only subs.
 790 ################################################################################
 791
 792 sub _perl_fingerprint {
 793     my($self,$other_fingerprint) = @_;
 794     my $dll = eval {OS2::DLLname()};
 795     my $mtime_dll = 0;
 796     if (defined $dll) {
 797         $mtime_dll = (-f $dll ? (stat(_))[9] : '-1');
 798     }
 799     my $mtime_perl = (-f $^X ? (stat(_))[9] : '-1');
 800     my $this_fingerprint = {
 801                             '$^X' => $^X,
 802                             sitearchexp => $Config::Config{sitearchexp},
 803                             'mtime_$^X' => $mtime_perl,
 804                             'mtime_dll' => $mtime_dll,
 805                            };
 806     if ($other_fingerprint) {
 807         if (exists $other_fingerprint->{'stat($^X)'}) { # repair fp from rev. 1.88_57
 808             $other_fingerprint->{'mtime_$^X'} = $other_fingerprint->{'stat($^X)'}[9];
 809         }
 810         # mandatory keys since 1.88_57
 811         for my $key (qw($^X sitearchexp mtime_dll mtime_$^X)) {
 812             return unless $other_fingerprint->{$key} eq $this_fingerprint->{$key};
 813         }
 814         return 1;
 815     } else {
 816         return $this_fingerprint;
 817     }
 818 }
 819
 820 sub suggest_myconfig () {
 821   SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) {
 822         $CPAN::Frontend->myprint("You don't seem to have a user ".
 823                                  "configuration (MyConfig.pm) yet.\n");
 824         my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ".
 825                                               "user configuration now? (Y/n)",
 826                                               "yes");
 827         if($new =~ m{^y}i) {
 828             CPAN::Shell->mkmyconfig();
 829             return &checklock;
 830         } else {
 831             $CPAN::Frontend->mydie("OK, giving up.");
 832         }
 833     }
 834 }
 835
 836 #-> sub CPAN::all_objects ;
 837 sub all_objects {
 838     my($mgr,$class) = @_;
 839     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 840     CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
 841     CPAN::Index->reload;
 842     values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
 843 }
 844
 845 # Called by shell, not in batch mode. In batch mode I see no risk in
 846 # having many processes updating something as installations are
 847 # continually checked at runtime. In shell mode I suspect it is
 848 # unintentional to open more than one shell at a time
 849
 850 #-> sub CPAN::checklock ;
 851 sub checklock {
 852     my($self) = @_;
 853     my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
 854     if (-f $lockfile && -M _ > 0) {
 855         my $fh = FileHandle->new($lockfile) or
 856             $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
 857         my $otherpid  = <$fh>;
 858         my $otherhost = <$fh>;
 859         $fh->close;
 860         if (defined $otherpid && $otherpid) {
 861             chomp $otherpid;
 862         }
 863         if (defined $otherhost && $otherhost) {
 864             chomp $otherhost;
 865         }
 866         my $thishost  = hostname();
 867         if (defined $otherhost && defined $thishost &&
 868             $otherhost ne '' && $thishost ne '' &&
 869             $otherhost ne $thishost) {
 870             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
 871                                            "reports other host $otherhost and other ".
 872                                            "process $otherpid.\n".
 873                                            "Cannot proceed.\n"));
 874         } elsif ($RUN_DEGRADED) {
 875             $CPAN::Frontend->mywarn("Running in degraded mode (experimental)\n");
 876         } elsif (defined $otherpid && $otherpid) {
 877             return if $$ == $otherpid; # should never happen
 878             $CPAN::Frontend->mywarn(
 879                                     qq{
 880 There seems to be running another CPAN process (pid $otherpid).  Contacting...
 881 });
 882             if (kill 0, $otherpid) {
 883                 $CPAN::Frontend->mywarn(qq{Other job is running.\n});
 884                 my($ans) =
 885                     CPAN::Shell::colorable_makemaker_prompt
 886                         (qq{Shall I try to run in degraded }.
 887                          qq{mode? (Y/n)},"y");
 888                 if ($ans =~ /^y/i) {
 889                     $CPAN::Frontend->mywarn("Running in degraded mode (experimental).
 890 Please report if something unexpected happens\n");
 891                     $RUN_DEGRADED = 1;
 892                     for ($CPAN::Config) {
 893                         # XXX
 894                         # $_->{build_dir_reuse} = 0; # 2006-11-17 akoenig Why was that?
 895                         $_->{commandnumber_in_prompt} = 0; # visibility
 896                         $_->{histfile} = "";               # who should win otherwise?
 897                         $_->{cache_metadata} = 0;          # better would be a lock?
 898                         $_->{use_sqlite} = 0;              # better would be a write lock!
 899                     }
 900                 } else {
 901                     $CPAN::Frontend->mydie("
 902 You may want to kill the other job and delete the lockfile. On UNIX try:
 903     kill $otherpid
 904     rm $lockfile
 905 ");
 906                 }
 907             } elsif (-w $lockfile) {
 908                 my($ans) =
 909                     CPAN::Shell::colorable_makemaker_prompt
 910                         (qq{Other job not responding. Shall I overwrite }.
 911                          qq{the lockfile '$lockfile'? (Y/n)},"y");
 912                 $CPAN::Frontend->myexit("Ok, bye\n")
 913                     unless $ans =~ /^y/i;
 914             } else {
 915                 Carp::croak(
 916                             qq{Lockfile '$lockfile' not writeable by you. }.
 917                             qq{Cannot proceed.\n}.
 918                             qq{    On UNIX try:\n}.
 919                             qq{    rm '$lockfile'\n}.
 920                             qq{  and then rerun us.\n}
 921                            );
 922             }
 923         } else {
 924             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Found invalid lockfile ".
 925                                            "'$lockfile', please remove. Cannot proceed.\n"));
 926         }
 927     }
 928     my $dotcpan = $CPAN::Config->{cpan_home};
 929     eval { File::Path::mkpath($dotcpan);};
 930     if ($@) {
 931         # A special case at least for Jarkko.
 932         my $firsterror = $@;
 933         my $seconderror;
 934         my $symlinkcpan;
 935         if (-l $dotcpan) {
 936             $symlinkcpan = readlink $dotcpan;
 937             die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
 938             eval { File::Path::mkpath($symlinkcpan); };
 939             if ($@) {
 940                 $seconderror = $@;
 941             } else {
 942                 $CPAN::Frontend->mywarn(qq{
 943 Working directory $symlinkcpan created.
 944 });
 945             }
 946         }
 947         unless (-d $dotcpan) {
 948             my $mess = qq{
 949 Your configuration suggests "$dotcpan" as your
 950 CPAN.pm working directory. I could not create this directory due
 951 to this error: $firsterror\n};
 952             $mess .= qq{
 953 As "$dotcpan" is a symlink to "$symlinkcpan",
 954 I tried to create that, but I failed with this error: $seconderror
 955 } if $seconderror;
 956             $mess .= qq{
 957 Please make sure the directory exists and is writable.
 958 };
 959             $CPAN::Frontend->myprint($mess);
 960             return suggest_myconfig;
 961         }
 962     } # $@ after eval mkpath $dotcpan
 963     if (0) { # to test what happens when a race condition occurs
 964         for (reverse 1..10) {
 965             print $_, "\n";
 966             sleep 1;
 967         }
 968     }
 969     # locking
 970     if (!$RUN_DEGRADED && !$self->{LOCKFH}) {
 971         my $fh;
 972         unless ($fh = FileHandle->new("+>>$lockfile")) {
 973             if ($! =~ /Permission/) {
 974                 $CPAN::Frontend->myprint(qq{
 975
 976 Your configuration suggests that CPAN.pm should use a working
 977 directory of
 978     $CPAN::Config->{cpan_home}
 979 Unfortunately we could not create the lock file
 980     $lockfile
 981 due to permission problems.
 982
 983 Please make sure that the configuration variable
 984     \$CPAN::Config->{cpan_home}
 985 points to a directory where you can write a .lock file. You can set
 986 this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
 987 \@INC path;
 988 });
 989                 return suggest_myconfig;
 990             }
 991         }
 992         my $sleep = 1;
 993         while (!flock $fh, LOCK_EX|LOCK_NB) {
 994             if ($sleep>10) {
 995                 $CPAN::Frontend->mydie("Giving up\n");
 996             }
 997             $CPAN::Frontend->mysleep($sleep++);
 998             $CPAN::Frontend->mywarn("Could not lock lockfile with flock: $!; retrying\n");
 999         }
1000
1001         seek $fh, 0, 0;
1002         truncate $fh, 0;
1003         $fh->print($$, "\n");
1004         $fh->print(hostname(), "\n");
1005         $self->{LOCK} = $lockfile;
1006         $self->{LOCKFH} = $fh;
1007     }
1008     $SIG{TERM} = sub {
1009         my $sig = shift;
1010         &cleanup;
1011         $CPAN::Frontend->mydie("Got SIG$sig, leaving");
1012     };
1013     $SIG{INT} = sub {
1014       # no blocks!!!
1015         my $sig = shift;
1016         &cleanup if $Signal;
1017         die "Got yet another signal" if $Signal > 1;
1018         $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal;
1019         $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n");
1020         $Signal++;
1021     };
1022
1023 #       From: Larry Wall <larry@wall.org>
1024 #       Subject: Re: deprecating SIGDIE
1025 #       To: perl5-porters@perl.org
1026 #       Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
1027 #
1028 #       The original intent of __DIE__ was only to allow you to substitute one
1029 #       kind of death for another on an application-wide basis without respect
1030 #       to whether you were in an eval or not.  As a global backstop, it should
1031 #       not be used any more lightly (or any more heavily :-) than class
1032 #       UNIVERSAL.  Any attempt to build a general exception model on it should
1033 #       be politely squashed.  Any bug that causes every eval {} to have to be
1034 #       modified should be not so politely squashed.
1035 #
1036 #       Those are my current opinions.  It is also my optinion that polite
1037 #       arguments degenerate to personal arguments far too frequently, and that
1038 #       when they do, it's because both people wanted it to, or at least didn't
1039 #       sufficiently want it not to.
1040 #
1041 #       Larry
1042
1043     # global backstop to cleanup if we should really die
1044     $SIG{__DIE__} = \&cleanup;
1045     $self->debug("Signal handler set.") if $CPAN::DEBUG;
1046 }
1047
1048 #-> sub CPAN::DESTROY ;
1049 sub DESTROY {
1050     &cleanup; # need an eval?
1051 }
1052
1053 #-> sub CPAN::anycwd ;
1054 sub anycwd () {
1055     my $getcwd;
1056     $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
1057     CPAN->$getcwd();
1058 }
1059
1060 #-> sub CPAN::cwd ;
1061 sub cwd {Cwd::cwd();}
1062
1063 #-> sub CPAN::getcwd ;
1064 sub getcwd {Cwd::getcwd();}
1065
1066 #-> sub CPAN::fastcwd ;
1067 sub fastcwd {Cwd::fastcwd();}
1068
1069 #-> sub CPAN::backtickcwd ;
1070 sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
1071
1072 #-> sub CPAN::find_perl ;
1073 sub find_perl {
1074     my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
1075     my $pwd  = $CPAN::iCwd = CPAN::anycwd();
1076     my $candidate = File::Spec->catfile($pwd,$^X);
1077     $perl ||= $candidate if MM->maybe_command($candidate);
1078
1079     unless ($perl) {
1080         my ($component,$perl_name);
1081       DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
1082             PATH_COMPONENT: foreach $component (File::Spec->path(),
1083                                                 $Config::Config{'binexp'}) {
1084                   next unless defined($component) && $component;
1085                   my($abs) = File::Spec->catfile($component,$perl_name);
1086                   if (MM->maybe_command($abs)) {
1087                       $perl = $abs;
1088                       last DIST_PERLNAME;
1089                   }
1090               }
1091           }
1092     }
1093
1094     return $perl;
1095 }
1096
1097
1098 #-> sub CPAN::exists ;
1099 sub exists {
1100     my($mgr,$class,$id) = @_;
1101     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
1102     CPAN::Index->reload;
1103     ### Carp::croak "exists called without class argument" unless $class;
1104     $id ||= "";
1105     $id =~ s/:+/::/g if $class eq "CPAN::Module";
1106     my $exists;
1107     if (CPAN::_sqlite_running) {
1108         $exists = (exists $META->{readonly}{$class}{$id} or
1109                    $CPAN::SQLite->set($class, $id));
1110     } else {
1111         $exists =  exists $META->{readonly}{$class}{$id};
1112     }
1113     $exists ||= exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
1114 }
1115
1116 #-> sub CPAN::delete ;
1117 sub delete {
1118   my($mgr,$class,$id) = @_;
1119   delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
1120   delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
1121 }
1122
1123 #-> sub CPAN::has_usable
1124 # has_inst is sometimes too optimistic, we should replace it with this
1125 # has_usable whenever a case is given
1126 sub has_usable {
1127     my($self,$mod,$message) = @_;
1128     return 1 if $HAS_USABLE->{$mod};
1129     my $has_inst = $self->has_inst($mod,$message);
1130     return unless $has_inst;
1131     my $usable;
1132     $usable = {
1133                LWP => [ # we frequently had "Can't locate object
1134                         # method "new" via package "LWP::UserAgent" at
1135                         # (eval 69) line 2006
1136                        sub {require LWP},
1137                        sub {require LWP::UserAgent},
1138                        sub {require HTTP::Request},
1139                        sub {require URI::URL},
1140                       ],
1141                'Net::FTP' => [
1142                             sub {require Net::FTP},
1143                             sub {require Net::Config},
1144                            ],
1145                'File::HomeDir' => [
1146                                    sub {require File::HomeDir;
1147                                         unless (File::HomeDir::->VERSION >= 0.52){
1148                                             for ("Will not use File::HomeDir, need 0.52\n") {
1149                                                 $CPAN::Frontend->mywarn($_);
1150                                                 die $_;
1151                                             }
1152                                         }
1153                                     },
1154                                   ],
1155                'Archive::Tar' => [
1156                                   sub {require Archive::Tar;
1157                                        unless (Archive::Tar::->VERSION >= 1.00) {
1158                                             for ("Will not use Archive::Tar, need 1.00\n") {
1159                                                 $CPAN::Frontend->mywarn($_);
1160                                                 die $_;
1161                                             }
1162                                        }
1163                                   },
1164                                  ],
1165               };
1166     if ($usable->{$mod}) {
1167         for my $c (0..$#{$usable->{$mod}}) {
1168             my $code = $usable->{$mod}[$c];
1169             my $ret = eval { &$code() };
1170             $ret = "" unless defined $ret;
1171             if ($@) {
1172                 # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
1173                 return;
1174             }
1175         }
1176     }
1177     return $HAS_USABLE->{$mod} = 1;
1178 }
1179
1180 #-> sub CPAN::has_inst
1181 sub has_inst {
1182     my($self,$mod,$message) = @_;
1183     Carp::croak("CPAN->has_inst() called without an argument")
1184         unless defined $mod;
1185     my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
1186         keys %{$CPAN::Config->{dontload_hash}||{}},
1187             @{$CPAN::Config->{dontload_list}||[]};
1188     if (defined $message && $message eq "no"  # afair only used by Nox
1189         ||
1190         $dont{$mod}
1191        ) {
1192       $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
1193       return 0;
1194     }
1195     my $file = $mod;
1196     my $obj;
1197     $file =~ s|::|/|g;
1198     $file .= ".pm";
1199     if ($INC{$file}) {
1200         # checking %INC is wrong, because $INC{LWP} may be true
1201         # although $INC{"URI/URL.pm"} may have failed. But as
1202         # I really want to say "bla loaded OK", I have to somehow
1203         # cache results.
1204         ### warn "$file in %INC"; #debug
1205         return 1;
1206     } elsif (eval { require $file }) {
1207         # eval is good: if we haven't yet read the database it's
1208         # perfect and if we have installed the module in the meantime,
1209         # it tries again. The second require is only a NOOP returning
1210         # 1 if we had success, otherwise it's retrying
1211
1212         my $v = eval "\$$mod\::VERSION";
1213         $v = $v ? " (v$v)" : "";
1214         $CPAN::Frontend->myprint("CPAN: $mod loaded ok$v\n");
1215         if ($mod eq "CPAN::WAIT") {
1216             push @CPAN::Shell::ISA, 'CPAN::WAIT';
1217         }
1218         return 1;
1219     } elsif ($mod eq "Net::FTP") {
1220         $CPAN::Frontend->mywarn(qq{
1221   Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
1222   if you just type
1223       install Bundle::libnet
1224
1225 }) unless $Have_warned->{"Net::FTP"}++;
1226         $CPAN::Frontend->mysleep(3);
1227     } elsif ($mod eq "Digest::SHA"){
1228         if ($Have_warned->{"Digest::SHA"}++) {
1229             $CPAN::Frontend->myprint(qq{CPAN: checksum security checks disabled }.
1230                                      qq{because Digest::SHA not installed.\n});
1231         } else {
1232             $CPAN::Frontend->mywarn(qq{
1233   CPAN: checksum security checks disabled because Digest::SHA not installed.
1234   Please consider installing the Digest::SHA module.
1235
1236 });
1237             $CPAN::Frontend->mysleep(2);
1238         }
1239     } elsif ($mod eq "Module::Signature"){
1240         # NOT prefs_lookup, we are not a distro
1241         my $check_sigs = $CPAN::Config->{check_sigs};
1242         if (not $check_sigs) {
1243             # they do not want us:-(
1244         } elsif (not $Have_warned->{"Module::Signature"}++) {
1245             # No point in complaining unless the user can
1246             # reasonably install and use it.
1247             if (eval { require Crypt::OpenPGP; 1 } ||
1248                 (
1249                  defined $CPAN::Config->{'gpg'}
1250                  &&
1251                  $CPAN::Config->{'gpg'} =~ /\S/
1252                 )
1253                ) {
1254                 $CPAN::Frontend->mywarn(qq{
1255   CPAN: Module::Signature security checks disabled because Module::Signature
1256   not installed.  Please consider installing the Module::Signature module.
1257   You may also need to be able to connect over the Internet to the public
1258   keyservers like pgp.mit.edu (port 11371).
1259
1260 });
1261                 $CPAN::Frontend->mysleep(2);
1262             }
1263         }
1264     } else {
1265         delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
1266     }
1267     return 0;
1268 }
1269
1270 #-> sub CPAN::instance ;
1271 sub instance {
1272     my($mgr,$class,$id) = @_;
1273     CPAN::Index->reload;
1274     $id ||= "";
1275     # unsafe meta access, ok?
1276     return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
1277     $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
1278 }
1279
1280 #-> sub CPAN::new ;
1281 sub new {
1282     bless {}, shift;
1283 }
1284
1285 #-> sub CPAN::cleanup ;
1286 sub cleanup {
1287   # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
1288   local $SIG{__DIE__} = '';
1289   my($message) = @_;
1290   my $i = 0;
1291   my $ineval = 0;
1292   my($subroutine);
1293   while ((undef,undef,undef,$subroutine) = caller(++$i)) {
1294       $ineval = 1, last if
1295           $subroutine eq '(eval)';
1296   }
1297   return if $ineval && !$CPAN::End;
1298   return unless defined $META->{LOCK};
1299   return unless -f $META->{LOCK};
1300   $META->savehist;
1301   close $META->{LOCKFH};
1302   unlink $META->{LOCK};
1303   # require Carp;
1304   # Carp::cluck("DEBUGGING");
1305   if ( $CPAN::CONFIG_DIRTY ) {
1306       $CPAN::Frontend->mywarn("Warning: Configuration not saved.\n");
1307   }
1308   $CPAN::Frontend->myprint("Lockfile removed.\n");
1309 }
1310
1311 #-> sub CPAN::readhist
1312 sub readhist {
1313     my($self,$term,$histfile) = @_;
1314     my($fh) = FileHandle->new;
1315     open $fh, "<$histfile" or last;
1316     local $/ = "\n";
1317     while (<$fh>) {
1318         chomp;
1319         $term->AddHistory($_);
1320     }
1321     close $fh;
1322 }
1323
1324 #-> sub CPAN::savehist
1325 sub savehist {
1326     my($self) = @_;
1327     my($histfile,$histsize);
1328     unless ($histfile = $CPAN::Config->{'histfile'}){
1329         $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
1330         return;
1331     }
1332     $histsize = $CPAN::Config->{'histsize'} || 100;
1333     if ($CPAN::term){
1334         unless ($CPAN::term->can("GetHistory")) {
1335             $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
1336             return;
1337         }
1338     } else {
1339         return;
1340     }
1341     my @h = $CPAN::term->GetHistory;
1342     splice @h, 0, @h-$histsize if @h>$histsize;
1343     my($fh) = FileHandle->new;
1344     open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
1345     local $\ = local $, = "\n";
1346     print $fh @h;
1347     close $fh;
1348 }
1349
1350 #-> sub CPAN::is_tested
1351 sub is_tested {
1352     my($self,$what,$when) = @_;
1353     unless ($what) {
1354         Carp::cluck("DEBUG: empty what");
1355         return;
1356     }
1357     $self->{is_tested}{$what} = $when;
1358 }
1359
1360 #-> sub CPAN::is_installed
1361 # unsets the is_tested flag: as soon as the thing is installed, it is
1362 # not needed in set_perl5lib anymore
1363 sub is_installed {
1364     my($self,$what) = @_;
1365     delete $self->{is_tested}{$what};
1366 }
1367
1368 sub _list_sorted_descending_is_tested {
1369     my($self) = @_;
1370     sort
1371         { ($self->{is_tested}{$b}||0) <=> ($self->{is_tested}{$a}||0) }
1372             keys %{$self->{is_tested}}
1373 }
1374
1375 #-> sub CPAN::set_perl5lib
1376 sub set_perl5lib {
1377     my($self,$for) = @_;
1378     unless ($for) {
1379         (undef,undef,undef,$for) = caller(1);
1380         $for =~ s/.*://;
1381     }
1382     $self->{is_tested} ||= {};
1383     return unless %{$self->{is_tested}};
1384     my $env = $ENV{PERL5LIB};
1385     $env = $ENV{PERLLIB} unless defined $env;
1386     my @env;
1387     push @env, $env if defined $env and length $env;
1388     #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
1389     #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
1390
1391     my @dirs = map {("$_/blib/arch", "$_/blib/lib")} $self->_list_sorted_descending_is_tested;
1392     if (@dirs < 12) {
1393         $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB for '$for'\n");
1394     } elsif (@dirs < 24) {
1395         my @d = map {my $cp = $_;
1396                      $cp =~ s/^\Q$CPAN::Config->{build_dir}\E/%BUILDDIR%/;
1397                      $cp
1398                  } @dirs;
1399         $CPAN::Frontend->myprint("Prepending @d to PERL5LIB; ".
1400                                  "%BUILDDIR%=$CPAN::Config->{build_dir} ".
1401                                  "for '$for'\n"
1402                                 );
1403     } else {
1404         my $cnt = keys %{$self->{is_tested}};
1405         $CPAN::Frontend->myprint("Prepending blib/arch and blib/lib of ".
1406                                  "$cnt build dirs to PERL5LIB; ".
1407                                  "for '$for'\n"
1408                                 );
1409     }
1410
1411     $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1412 }
1413
1414 package CPAN::CacheMgr;
1415 use strict;
1416
1417 #-> sub CPAN::CacheMgr::as_string ;
1418 sub as_string {
1419     eval { require Data::Dumper };
1420     if ($@) {
1421         return shift->SUPER::as_string;
1422     } else {
1423         return Data::Dumper::Dumper(shift);
1424     }
1425 }
1426
1427 #-> sub CPAN::CacheMgr::cachesize ;
1428 sub cachesize {
1429     shift->{DU};
1430 }
1431
1432 #-> sub CPAN::CacheMgr::tidyup ;
1433 sub tidyup {
1434   my($self) = @_;
1435   return unless $CPAN::META->{LOCK};
1436   return unless -d $self->{ID};
1437   while ($self->{DU} > $self->{'MAX'} ) {
1438     my($toremove) = shift @{$self->{FIFO}};
1439     unless ($toremove =~ /\.yml$/) {
1440         $CPAN::Frontend->myprint(sprintf(
1441                                          "DEL(%.1f>%.1fMB): %s \n",
1442                                          $self->{DU},
1443                                          $self->{MAX},
1444                                          $toremove,
1445                                         )
1446                                 );
1447     }
1448     return if $CPAN::Signal;
1449     $self->_clean_cache($toremove);
1450     return if $CPAN::Signal;
1451   }
1452 }
1453
1454 #-> sub CPAN::CacheMgr::dir ;
1455 sub dir {
1456     shift->{ID};
1457 }
1458
1459 #-> sub CPAN::CacheMgr::entries ;
1460 sub entries {
1461     my($self,$dir) = @_;
1462     return unless defined $dir;
1463     $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
1464     $dir ||= $self->{ID};
1465     my($cwd) = CPAN::anycwd();
1466     chdir $dir or Carp::croak("Can't chdir to $dir: $!");
1467     my $dh = DirHandle->new(File::Spec->curdir)
1468         or Carp::croak("Couldn't opendir $dir: $!");
1469     my(@entries);
1470     for ($dh->read) {
1471         next if $_ eq "." || $_ eq "..";
1472         if (-f $_) {
1473             push @entries, File::Spec->catfile($dir,$_);
1474         } elsif (-d _) {
1475             push @entries, File::Spec->catdir($dir,$_);
1476         } else {
1477             $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
1478         }
1479     }
1480     chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
1481     sort { -M $b <=> -M $a} @entries;
1482 }
1483
1484 #-> sub CPAN::CacheMgr::disk_usage ;
1485 sub disk_usage {
1486     my($self,$dir) = @_;
1487     return if exists $self->{SIZE}{$dir};
1488     return if $CPAN::Signal;
1489     my($Du) = 0;
1490     if (-e $dir) {
1491         if (-d $dir) {
1492             unless (-x $dir) {
1493                 unless (chmod 0755, $dir) {
1494                     $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
1495                                             "permission to change the permission; cannot ".
1496                                             "estimate disk usage of '$dir'\n");
1497                     $CPAN::Frontend->mysleep(5);
1498                     return;
1499                 }
1500             }
1501         } elsif (-f $dir) {
1502             # nothing to say, no matter what the permissions
1503         }
1504     } else {
1505         $CPAN::Frontend->mywarn("File or directory '$dir' has gone, ignoring\n");
1506         return;
1507     }
1508     find(
1509          sub {
1510            $File::Find::prune++ if $CPAN::Signal;
1511            return if -l $_;
1512            if ($^O eq 'MacOS') {
1513              require Mac::Files;
1514              my $cat  = Mac::Files::FSpGetCatInfo($_);
1515              $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
1516            } else {
1517              if (-d _) {
1518                unless (-x _) {
1519                  unless (chmod 0755, $_) {
1520                    $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
1521                                            "the permission to change the permission; ".
1522                                            "can only partially estimate disk usage ".
1523                                            "of '$_'\n");
1524                    $CPAN::Frontend->mysleep(5);
1525                    return;
1526                  }
1527                }
1528              } else {
1529                $Du += (-s _);
1530              }
1531            }
1532          },
1533          $dir
1534         );
1535     return if $CPAN::Signal;
1536     $self->{SIZE}{$dir} = $Du/1024/1024;
1537     push @{$self->{FIFO}}, $dir;
1538     $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
1539     $self->{DU} += $Du/1024/1024;
1540     $self->{DU};
1541 }
1542
1543 #-> sub CPAN::CacheMgr::_clean_cache ;
1544 sub _clean_cache {
1545     my($self,$dir) = @_;
1546     return unless -e $dir;
1547     unless (File::Spec->canonpath(File::Basename::dirname($dir))
1548             eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
1549         $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
1550                                 "will not remove\n");
1551         $CPAN::Frontend->mysleep(5);
1552         return;
1553     }
1554     $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
1555         if $CPAN::DEBUG;
1556     File::Path::rmtree($dir);
1557     my $id_deleted = 0;
1558     if ($dir !~ /\.yml$/ && -f "$dir.yml") {
1559         my $yaml_module = CPAN::_yaml_module;
1560         if ($CPAN::META->has_inst($yaml_module)) {
1561             my($peek_yaml) = CPAN->_yaml_loadfile("$dir.yml");
1562             if (my $id = $peek_yaml->[0]{distribution}{ID}) {
1563                 $CPAN::META->delete("CPAN::Distribution", $id);
1564                 # $CPAN::Frontend->mywarn (" +++\n");
1565                 $id_deleted++;
1566             }
1567         }
1568         unlink "$dir.yml"; # may fail
1569         unless ($id_deleted) {
1570             CPAN->debug("no distro found associated with '$dir'");
1571         }
1572     }
1573     $self->{DU} -= $self->{SIZE}{$dir};
1574     delete $self->{SIZE}{$dir};
1575 }
1576
1577 #-> sub CPAN::CacheMgr::new ;
1578 sub new {
1579     my $class = shift;
1580     my $time = time;
1581     my($debug,$t2);
1582     $debug = "";
1583     my $self = {
1584                 ID => $CPAN::Config->{build_dir},
1585                 MAX => $CPAN::Config->{'build_cache'},
1586                 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
1587                 DU => 0
1588                };
1589     File::Path::mkpath($self->{ID});
1590     my $dh = DirHandle->new($self->{ID});
1591     bless $self, $class;
1592     $self->scan_cache;
1593     $t2 = time;
1594     $debug .= "timing of CacheMgr->new: ".($t2 - $time);
1595     $time = $t2;
1596     CPAN->debug($debug) if $CPAN::DEBUG;
1597     $self;
1598 }
1599
1600 #-> sub CPAN::CacheMgr::scan_cache ;
1601 sub scan_cache {
1602     my $self = shift;
1603     return if $self->{SCAN} eq 'never';
1604     $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
1605         unless $self->{SCAN} eq 'atstart';
1606     return unless $CPAN::META->{LOCK};
1607     $CPAN::Frontend->myprint(
1608                              sprintf("Scanning cache %s for sizes\n",
1609                                      $self->{ID}));
1610     my $e;
1611     my @entries = grep { !/^\.\.?$/ } $self->entries($self->{ID});
1612     my $i = 0;
1613     my $painted = 0;
1614     for $e (@entries) {
1615         # next if $e eq ".." || $e eq ".";
1616         $self->disk_usage($e);
1617         $i++;
1618         while (($painted/76) < ($i/@entries)) {
1619             $CPAN::Frontend->myprint(".");
1620             $painted++;
1621         }
1622         return if $CPAN::Signal;
1623     }
1624     $CPAN::Frontend->myprint("DONE\n");
1625     $self->tidyup;
1626 }
1627
1628 package CPAN::Shell;
1629 use strict;
1630
1631 #-> sub CPAN::Shell::h ;
1632 sub h {
1633     my($class,$about) = @_;
1634     if (defined $about) {
1635         $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1636     } else {
1637         my $filler = " " x (80 - 28 - length($CPAN::VERSION));
1638         $CPAN::Frontend->myprint(qq{
1639 Display Information $filler (ver $CPAN::VERSION)
1640  command  argument          description
1641  a,b,d,m  WORD or /REGEXP/  about authors, bundles, distributions, modules
1642  i        WORD or /REGEXP/  about any of the above
1643  ls       AUTHOR or GLOB    about files in the author's directory
1644     (with WORD being a module, bundle or author name or a distribution
1645     name of the form AUTHOR/DISTRIBUTION)
1646
1647 Download, Test, Make, Install...
1648  get      download                     clean    make clean
1649  make     make (implies get)           look     open subshell in dist directory
1650  test     make test (implies make)     readme   display these README files
1651  install  make install (implies test)  perldoc  display POD documentation
1652
1653 Upgrade
1654  r        WORDs or /REGEXP/ or NONE    report updates for some/matching/all modules
1655  upgrade  WORDs or /REGEXP/ or NONE    upgrade some/matching/all modules
1656
1657 Pragmas
1658  force  CMD    try hard to do command  fforce CMD    try harder
1659  notest CMD    skip testing
1660
1661 Other
1662  h,?           display this menu       ! perl-code   eval a perl command
1663  o conf [opt]  set and query options   q             quit the cpan shell
1664  reload cpan   load CPAN.pm again      reload index  load newer indices
1665  autobundle    Snapshot                recent        latest CPAN uploads});
1666 }
1667 }
1668
1669 *help = \&h;
1670
1671 #-> sub CPAN::Shell::a ;
1672 sub a {
1673   my($self,@arg) = @_;
1674   # authors are always UPPERCASE
1675   for (@arg) {
1676     $_ = uc $_ unless /=/;
1677   }
1678   $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1679 }
1680
1681 #-> sub CPAN::Shell::globls ;
1682 sub globls {
1683     my($self,$s,$pragmas) = @_;
1684     # ls is really very different, but we had it once as an ordinary
1685     # command in the Shell (upto rev. 321) and we could not handle
1686     # force well then
1687     my(@accept,@preexpand);
1688     if ($s =~ /[\*\?\/]/) {
1689         if ($CPAN::META->has_inst("Text::Glob")) {
1690             if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
1691                 my $rau = Text::Glob::glob_to_regex(uc $au);
1692                 CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
1693                       if $CPAN::DEBUG;
1694                 push @preexpand, map { $_->id . "/" . $pathglob }
1695                     CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
1696             } else {
1697                 my $rau = Text::Glob::glob_to_regex(uc $s);
1698                 push @preexpand, map { $_->id }
1699                     CPAN::Shell->expand_by_method('CPAN::Author',
1700                                                   ['id'],
1701                                                   "/$rau/");
1702             }
1703         } else {
1704             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
1705         }
1706     } else {
1707         push @preexpand, uc $s;
1708     }
1709     for (@preexpand) {
1710         unless (/^[A-Z0-9\-]+(\/|$)/i) {
1711             $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
1712             next;
1713         }
1714         push @accept, $_;
1715     }
1716     my $silent = @accept>1;
1717     my $last_alpha = "";
1718     my @results;
1719     for my $a (@accept){
1720         my($author,$pathglob);
1721         if ($a =~ m|(.*?)/(.*)|) {
1722             my $a2 = $1;
1723             $pathglob = $2;
1724             $author = CPAN::Shell->expand_by_method('CPAN::Author',
1725                                                     ['id'],
1726                                                     $a2)
1727                 or $CPAN::Frontend->mydie("No author found for $a2\n");
1728         } else {
1729             $author = CPAN::Shell->expand_by_method('CPAN::Author',
1730                                                     ['id'],
1731                                                     $a)
1732                 or $CPAN::Frontend->mydie("No author found for $a\n");
1733         }
1734         if ($silent) {
1735             my $alpha = substr $author->id, 0, 1;
1736             my $ad;
1737             if ($alpha eq $last_alpha) {
1738                 $ad = "";
1739             } else {
1740                 $ad = "[$alpha]";
1741                 $last_alpha = $alpha;
1742             }
1743             $CPAN::Frontend->myprint($ad);
1744         }
1745         for my $pragma (@$pragmas) {
1746             if ($author->can($pragma)) {
1747                 $author->$pragma();
1748             }
1749         }
1750         push @results, $author->ls($pathglob,$silent); # silent if
1751                                                        # more than one
1752                                                        # author
1753         for my $pragma (@$pragmas) {
1754             my $unpragma = "un$pragma";
1755             if ($author->can($unpragma)) {
1756                 $author->$unpragma();
1757             }
1758         }
1759     }
1760     @results;
1761 }
1762
1763 #-> sub CPAN::Shell::local_bundles ;
1764 sub local_bundles {
1765     my($self,@which) = @_;
1766     my($incdir,$bdir,$dh);
1767     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1768         my @bbase = "Bundle";
1769         while (my $bbase = shift @bbase) {
1770             $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
1771             CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1772             if ($dh = DirHandle->new($bdir)) { # may fail
1773                 my($entry);
1774                 for $entry ($dh->read) {
1775                     next if $entry =~ /^\./;
1776                     next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/;
1777                     if (-d File::Spec->catdir($bdir,$entry)){
1778                         push @bbase, "$bbase\::$entry";
1779                     } else {
1780                         next unless $entry =~ s/\.pm(?!\n)\Z//;
1781                         $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1782                     }
1783                 }
1784             }
1785         }
1786     }
1787 }
1788
1789 #-> sub CPAN::Shell::b ;
1790 sub b {
1791     my($self,@which) = @_;
1792     CPAN->debug("which[@which]") if $CPAN::DEBUG;
1793     $self->local_bundles;
1794     $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1795 }
1796
1797 #-> sub CPAN::Shell::d ;
1798 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1799
1800 #-> sub CPAN::Shell::m ;
1801 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1802     my $self = shift;
1803     $CPAN::Frontend->myprint($self->format_result('Module',@_));
1804 }
1805
1806 #-> sub CPAN::Shell::i ;
1807 sub i {
1808     my($self) = shift;
1809     my(@args) = @_;
1810     @args = '/./' unless @args;
1811     my(@result);
1812     for my $type (qw/Bundle Distribution Module/) {
1813         push @result, $self->expand($type,@args);
1814     }
1815     # Authors are always uppercase.
1816     push @result, $self->expand("Author", map { uc $_ } @args);
1817
1818     my $result = @result == 1 ?
1819         $result[0]->as_string :
1820             @result == 0 ?
1821                 "No objects found of any type for argument @args\n" :
1822                     join("",
1823                          (map {$_->as_glimpse} @result),
1824                          scalar @result, " items found\n",
1825                         );
1826     $CPAN::Frontend->myprint($result);
1827 }
1828
1829 #-> sub CPAN::Shell::o ;
1830
1831 # CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o
1832 # conf' calls through to CPAN::HandleConfig::edit. 'o conf' should
1833 # probably have been called 'set' and 'o debug' maybe 'set debug' or
1834 # 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm
1835 sub o {
1836     my($self,$o_type,@o_what) = @_;
1837     $o_type ||= "";
1838     CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1839     if ($o_type eq 'conf') {
1840         if (!@o_what) { # print all things, "o conf"
1841             my($k,$v);
1842             $CPAN::Frontend->myprint("\$CPAN::Config options from ");
1843             my @from;
1844             if (exists $INC{'CPAN/Config.pm'}) {
1845                 push @from, $INC{'CPAN/Config.pm'};
1846             }
1847             if (exists $INC{'CPAN/MyConfig.pm'}) {
1848                 push @from, $INC{'CPAN/MyConfig.pm'};
1849             }
1850             $CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from);
1851             $CPAN::Frontend->myprint(":\n");
1852             for $k (sort keys %CPAN::HandleConfig::can) {
1853                 $v = $CPAN::HandleConfig::can{$k};
1854                 $CPAN::Frontend->myprint(sprintf "    %-18s [%s]\n", $k, $v);
1855             }
1856             $CPAN::Frontend->myprint("\n");
1857             for $k (sort keys %$CPAN::Config) {
1858                 CPAN::HandleConfig->prettyprint($k);
1859             }
1860             $CPAN::Frontend->myprint("\n");
1861         } else {
1862             if (CPAN::HandleConfig->edit(@o_what)) {
1863             } else {
1864                 $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
1865                                          qq{items\n\n});
1866             }
1867         }
1868     } elsif ($o_type eq 'debug') {
1869         my(%valid);
1870         @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1871         if (@o_what) {
1872             while (@o_what) {
1873                 my($what) = shift @o_what;
1874                 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
1875                     $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
1876                     next;
1877                 }
1878                 if ( exists $CPAN::DEBUG{$what} ) {
1879                     $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1880                 } elsif ($what =~ /^\d/) {
1881                     $CPAN::DEBUG = $what;
1882                 } elsif (lc $what eq 'all') {
1883                     my($max) = 0;
1884                     for (values %CPAN::DEBUG) {
1885                         $max += $_;
1886                     }
1887                     $CPAN::DEBUG = $max;
1888                 } else {
1889                     my($known) = 0;
1890                     for (keys %CPAN::DEBUG) {
1891                         next unless lc($_) eq lc($what);
1892                         $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1893                         $known = 1;
1894                     }
1895                     $CPAN::Frontend->myprint("unknown argument [$what]\n")
1896                         unless $known;
1897                 }
1898             }
1899         } else {
1900           my $raw = "Valid options for debug are ".
1901               join(", ",sort(keys %CPAN::DEBUG), 'all').
1902                   qq{ or a number. Completion works on the options. }.
1903                       qq{Case is ignored.};
1904           require Text::Wrap;
1905           $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1906           $CPAN::Frontend->myprint("\n\n");
1907         }
1908         if ($CPAN::DEBUG) {
1909             $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n");
1910             my($k,$v);
1911             for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1912                 $v = $CPAN::DEBUG{$k};
1913                 $CPAN::Frontend->myprint(sprintf "    %-14s(%s)\n", $k, $v)
1914                     if $v & $CPAN::DEBUG;
1915             }
1916         } else {
1917             $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1918         }
1919     } else {
1920         $CPAN::Frontend->myprint(qq{
1921 Known options:
1922   conf    set or get configuration variables
1923   debug   set or get debugging options
1924 });
1925     }
1926 }
1927
1928 # CPAN::Shell::paintdots_onreload
1929 sub paintdots_onreload {
1930     my($ref) = shift;
1931     sub {
1932         if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
1933             my($subr) = $1;
1934             ++$$ref;
1935             local($|) = 1;
1936             # $CPAN::Frontend->myprint(".($subr)");
1937             $CPAN::Frontend->myprint(".");
1938             if ($subr =~ /\bshell\b/i) {
1939                 # warn "debug[$_[0]]";
1940
1941                 # It would be nice if we could detect that a
1942                 # subroutine has actually changed, but for now we
1943                 # practically always set the GOTOSHELL global
1944
1945                 $CPAN::GOTOSHELL=1;
1946             }
1947             return;
1948         }
1949         warn @_;
1950     };
1951 }
1952
1953 #-> sub CPAN::Shell::hosts ;
1954 sub hosts {
1955     my($self) = @_;
1956     my $fullstats = CPAN::FTP->_ftp_statistics();
1957     my $history = $fullstats->{history} || [];
1958     my %S; # statistics
1959     while (my $last = pop @$history) {
1960         my $attempts = $last->{attempts} or next;
1961         my $start;
1962         if (@$attempts) {
1963             $start = $attempts->[-1]{start};
1964             if ($#$attempts > 0) {
1965                 for my $i (0..$#$attempts-1) {
1966                     my $url = $attempts->[$i]{url} or next;
1967                     $S{no}{$url}++;
1968                 }
1969             }
1970         } else {
1971             $start = $last->{start};
1972         }
1973         next unless $last->{thesiteurl}; # C-C? bad filenames?
1974         $S{start} = $start;
1975         $S{end} ||= $last->{end};
1976         my $dltime = $last->{end} - $start;
1977         my $dlsize = $last->{filesize} || 0;
1978         my $url = ref $last->{thesiteurl} ? $last->{thesiteurl}->text : $last->{thesiteurl};
1979         my $s = $S{ok}{$url} ||= {};
1980         $s->{n}++;
1981         $s->{dlsize} ||= 0;
1982         $s->{dlsize} += $dlsize/1024;
1983         $s->{dltime} ||= 0;
1984         $s->{dltime} += $dltime;
1985     }
1986     my $res;
1987     for my $url (keys %{$S{ok}}) {
1988         next if $S{ok}{$url}{dltime} == 0; # div by zero
1989         push @{$res->{ok}}, [@{$S{ok}{$url}}{qw(n dlsize dltime)},
1990                              $S{ok}{$url}{dlsize}/$S{ok}{$url}{dltime},
1991                              $url,
1992                             ];
1993     }
1994     for my $url (keys %{$S{no}}) {
1995         push @{$res->{no}}, [$S{no}{$url},
1996                              $url,
1997                             ];
1998     }
1999     my $R = ""; # report
2000     if ($S{start} && $S{end}) {
2001         $R .= sprintf "Log starts: %s\n", $S{start} ? scalar(localtime $S{start}) : "unknown";
2002         $R .= sprintf "Log ends  : %s\n", $S{end}   ? scalar(localtime $S{end})   : "unknown";
2003     }
2004     if ($res->{ok} && @{$res->{ok}}) {
2005         $R .= sprintf "\nSuccessful downloads:
2006    N       kB  secs      kB/s url\n";
2007         my $i = 20;
2008         for (sort { $b->[3] <=> $a->[3] } @{$res->{ok}}) {
2009             $R .= sprintf "%4d %8d %5d %9.1f %s\n", @$_;
2010             last if --$i<=0;
2011         }
2012     }
2013     if ($res->{no} && @{$res->{no}}) {
2014         $R .= sprintf "\nUnsuccessful downloads:\n";
2015         my $i = 20;
2016         for (sort { $b->[0] <=> $a->[0] } @{$res->{no}}) {
2017             $R .= sprintf "%4d %s\n", @$_;
2018             last if --$i<=0;
2019         }
2020     }
2021     $CPAN::Frontend->myprint($R);
2022 }
2023
2024 #-> sub CPAN::Shell::reload ;
2025 sub reload {
2026     my($self,$command,@arg) = @_;
2027     $command ||= "";
2028     $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
2029     if ($command =~ /^cpan$/i) {
2030         my $redef = 0;
2031         chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
2032         my $failed;
2033         my @relo = (
2034                     "CPAN.pm",
2035                     "CPAN/Debug.pm",
2036                     "CPAN/FirstTime.pm",
2037                     "CPAN/HandleConfig.pm",
2038                     "CPAN/Kwalify.pm",
2039                     "CPAN/Queue.pm",
2040                     "CPAN/Reporter.pm",
2041                     "CPAN/SQLite.pm",
2042                     "CPAN/Tarzip.pm",
2043                     "CPAN/Version.pm",
2044                    );
2045       MFILE: for my $f (@relo) {
2046             next unless exists $INC{$f};
2047             my $p = $f;
2048             $p =~ s/\.pm$//;
2049             $p =~ s|/|::|g;
2050             $CPAN::Frontend->myprint("($p");
2051             local($SIG{__WARN__}) = paintdots_onreload(\$redef);
2052             $self->_reload_this($f) or $failed++;
2053             my $v = eval "$p\::->VERSION";
2054             $CPAN::Frontend->myprint("v$v)");
2055         }
2056         $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
2057         if ($failed) {
2058             my $errors = $failed == 1 ? "error" : "errors";
2059             $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ".
2060                                     "this session.\n");
2061         }
2062     } elsif ($command =~ /^index$/i) {
2063       CPAN::Index->force_reload;
2064     } else {
2065       $CPAN::Frontend->myprint(qq{cpan     re-evals the CPAN modules
2066 index    re-reads the index files\n});
2067     }
2068 }
2069
2070 # reload means only load again what we have loaded before
2071 #-> sub CPAN::Shell::_reload_this ;
2072 sub _reload_this {
2073     my($self,$f,$args) = @_;
2074     CPAN->debug("f[$f]") if $CPAN::DEBUG;
2075     return 1 unless $INC{$f}; # we never loaded this, so we do not
2076                               # reload but say OK
2077     my $pwd = CPAN::anycwd();
2078     CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG;
2079     my($file);
2080     for my $inc (@INC) {
2081         $file = File::Spec->catfile($inc,split /\//, $f);
2082         last if -f $file;
2083         $file = "";
2084     }
2085     CPAN->debug("file[$file]") if $CPAN::DEBUG;
2086     my @inc = @INC;
2087     unless ($file && -f $file) {
2088         # this thingie is not in the INC path, maybe CPAN/MyConfig.pm?
2089         $file = $INC{$f};
2090         unless (CPAN->has_inst("File::Basename")) {
2091             @inc = File::Basename::dirname($file);
2092         } else {
2093             # do we ever need this?
2094             @inc = substr($file,0,-length($f)-1); # bring in back to me!
2095         }
2096     }
2097     CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG;
2098     unless (-f $file) {
2099         $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
2100         return;
2101     }
2102     my $mtime = (stat $file)[9];
2103     $reload->{$f} ||= $^T;
2104     my $must_reload = $mtime > $reload->{$f};
2105     $args ||= {};
2106     $must_reload ||= $args->{reloforce};
2107     if ($must_reload) {
2108         my $fh = FileHandle->new($file) or
2109             $CPAN::Frontend->mydie("Could not open $file: $!");
2110         local($/);
2111         local $^W = 1;
2112         my $content = <$fh>;
2113         CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
2114             if $CPAN::DEBUG;
2115         delete $INC{$f};
2116         local @INC = @inc;
2117         eval "require '$f'";
2118         if ($@){
2119             warn $@;
2120             return;
2121         }
2122         $reload->{$f} = time;
2123     } else {
2124         $CPAN::Frontend->myprint("__unchanged__");
2125     }
2126     return 1;
2127 }
2128
2129 #-> sub CPAN::Shell::mkmyconfig ;
2130 sub mkmyconfig {
2131     my($self, $cpanpm, %args) = @_;
2132     require CPAN::FirstTime;
2133     my $home = CPAN::HandleConfig::home;
2134     $cpanpm = $INC{'CPAN/MyConfig.pm'} ||
2135         File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm");
2136     File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm;
2137     CPAN::HandleConfig::require_myconfig_or_config;
2138     $CPAN::Config ||= {};
2139     $CPAN::Config = {
2140         %$CPAN::Config,
2141         build_dir           =>  undef,
2142         cpan_home           =>  undef,
2143         keep_source_where   =>  undef,
2144         histfile            =>  undef,
2145     };
2146     CPAN::FirstTime::init($cpanpm, %args);
2147 }
2148
2149 #-> sub CPAN::Shell::_binary_extensions ;
2150 sub _binary_extensions {
2151     my($self) = shift @_;
2152     my(@result,$module,%seen,%need,$headerdone);
2153     for $module ($self->expand('Module','/./')) {
2154         my $file  = $module->cpan_file;
2155         next if $file eq "N/A";
2156         next if $file =~ /^Contact Author/;
2157         my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
2158         next if $dist->isa_perl;
2159         next unless $module->xs_file;
2160         local($|) = 1;
2161         $CPAN::Frontend->myprint(".");
2162         push @result, $module;
2163     }
2164 #    print join " | ", @result;
2165     $CPAN::Frontend->myprint("\n");
2166     return @result;
2167 }
2168
2169 #-> sub CPAN::Shell::recompile ;
2170 sub recompile {
2171     my($self) = shift @_;
2172     my($module,@module,$cpan_file,%dist);
2173     @module = $self->_binary_extensions();
2174     for $module (@module){  # we force now and compile later, so we
2175                             # don't do it twice
2176         $cpan_file = $module->cpan_file;
2177         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
2178         $pack->force; #
2179         $dist{$cpan_file}++;
2180     }
2181     for $cpan_file (sort keys %dist) {
2182         $CPAN::Frontend->myprint("  CPAN: Recompiling $cpan_file\n\n");
2183         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
2184         $pack->install;
2185         $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
2186                            # stop a package from recompiling,
2187                            # e.g. IO-1.12 when we have perl5.003_10
2188     }
2189 }
2190
2191 #-> sub CPAN::Shell::scripts ;
2192 sub scripts {
2193     my($self, $arg) = @_;
2194     $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");
2195
2196     for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) {
2197         unless ($CPAN::META->has_inst($req)) {
2198             $CPAN::Frontend->mywarn("  $req not available\n");
2199         }
2200     }
2201     my $p = HTML::LinkExtor->new();
2202     my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html";
2203     unless (-f $indexfile) {
2204         $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n");
2205     }
2206     $p->parse_file($indexfile);
2207     my @hrefs;
2208     my $qrarg;
2209     if ($arg =~ s|^/(.+)/$|$1|) {
2210         $qrarg = eval 'qr/$arg/'; # hide construct from 5.004
2211     }
2212     for my $l ($p->links) {
2213         my $tag = shift @$l;
2214         next unless $tag eq "a";
2215         my %att = @$l;
2216         my $href = $att{href};
2217         next unless $href =~ s|^\.\./authors/id/./../||;
2218         if ($arg) {
2219             if ($qrarg) {
2220                 if ($href =~ $qrarg) {
2221                     push @hrefs, $href;
2222                 }
2223             } else {
2224                 if ($href =~ /\Q$arg\E/) {
2225                     push @hrefs, $href;
2226                 }
2227             }
2228         } else {
2229             push @hrefs, $href;
2230         }
2231     }
2232     # now filter for the latest version if there is more than one of a name
2233     my %stems;
2234     for (sort @hrefs) {
2235         my $href = $_;
2236         s/-v?\d.*//;
2237         my $stem = $_;
2238         $stems{$stem} ||= [];
2239         push @{$stems{$stem}}, $href;
2240     }
2241     for (sort keys %stems) {
2242         my $highest;
2243         if (@{$stems{$_}} > 1) {
2244             $highest = List::Util::reduce {
2245                 Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b
2246               } @{$stems{$_}};
2247         } else {
2248             $highest = $stems{$_}[0];
2249         }
2250         $CPAN::Frontend->myprint("$highest\n");
2251     }
2252 }
2253
2254 #-> sub CPAN::Shell::report ;
2255 sub report {
2256     my($self,@args) = @_;
2257     unless ($CPAN::META->has_inst("CPAN::Reporter")) {
2258         $CPAN::Frontend->mydie("CPAN::Reporter not installed; cannot continue");
2259     }
2260     local $CPAN::Config->{test_report} = 1;
2261     $self->force("test",@args); # force is there so that the test be
2262                                 # re-run (as documented)
2263 }
2264
2265 # compare with is_tested
2266 #-> sub CPAN::Shell::install_tested
2267 sub install_tested {
2268     my($self,@some) = @_;
2269     $CPAN::Frontend->mywarn("install_tested() must not be called with arguments.\n"),
2270         return if @some;
2271     CPAN::Index->reload;
2272
2273     for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
2274         my $yaml = "$b.yml";
2275         unless (-f $yaml){
2276             $CPAN::Frontend->mywarn("No YAML file for $b available, skipping\n");
2277             next;
2278         }
2279         my $yaml_content = CPAN->_yaml_loadfile($yaml);
2280         my $id = $yaml_content->[0]{distribution}{ID};
2281         unless ($id){
2282             $CPAN::Frontend->mywarn("No ID found in '$yaml', skipping\n");
2283             next;
2284         }
2285         my $do = CPAN::Shell->expandany($id);
2286         unless ($do){
2287             $CPAN::Frontend->mywarn("Could not expand ID '$id', skipping\n");
2288             next;
2289         }
2290         unless ($do->{build_dir}) {
2291             $CPAN::Frontend->mywarn("Distro '$id' has no build_dir, skipping\n");
2292             next;
2293         }
2294         unless ($do->{build_dir} eq $b) {
2295             $CPAN::Frontend->mywarn("Distro '$id' has build_dir '$do->{build_dir}' but expected '$b', skipping\n");
2296             next;
2297         }
2298         push @some, $do;
2299     }
2300
2301     $CPAN::Frontend->mywarn("No tested distributions found.\n"),
2302         return unless @some;
2303
2304     @some = grep { $_->{make_test} && ! $_->{make_test}->failed } @some;
2305     $CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"),
2306         return unless @some;
2307
2308     # @some = grep { not $_->uptodate } @some;
2309     # $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"),
2310     #     return unless @some;
2311
2312     CPAN->debug("some[@some]");
2313     for my $d (@some) {
2314         my $id = $d->can("pretty_id") ? $d->pretty_id : $d->id;
2315         $CPAN::Frontend->myprint("install_tested: Running for $id\n");
2316         $CPAN::Frontend->mysleep(1);
2317         $self->install($d);
2318     }
2319 }
2320
2321 #-> sub CPAN::Shell::upgrade ;
2322 sub upgrade {
2323     my($self,@args) = @_;
2324     $self->install($self->r(@args));
2325 }
2326
2327 #-> sub CPAN::Shell::_u_r_common ;
2328 sub _u_r_common {
2329     my($self) = shift @_;
2330     my($what) = shift @_;
2331     CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
2332     Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
2333           $what && $what =~ /^[aru]$/;
2334     my(@args) = @_;
2335     @args = '/./' unless @args;
2336     my(@result,$module,%seen,%need,$headerdone,
2337        $version_undefs,$version_zeroes);
2338     $version_undefs = $version_zeroes = 0;
2339     my $sprintf = "%s%-25s%s %9s %9s  %s\n";
2340     my @expand = $self->expand('Module',@args);
2341     my $expand = scalar @expand;
2342     if (0) { # Looks like noise to me, was very useful for debugging
2343              # for metadata cache
2344         $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
2345     }
2346   MODULE: for $module (@expand) {
2347         my $file  = $module->cpan_file;
2348         next MODULE unless defined $file; # ??
2349         $file =~ s|^./../||;
2350         my($latest) = $module->cpan_version;
2351         my($inst_file) = $module->inst_file;
2352         my($have);
2353         return if $CPAN::Signal;
2354         if ($inst_file){
2355             if ($what eq "a") {
2356                 $have = $module->inst_version;
2357             } elsif ($what eq "r") {
2358                 $have = $module->inst_version;
2359                 local($^W) = 0;
2360                 if ($have eq "undef"){
2361                     $version_undefs++;
2362                 } elsif ($have == 0){
2363                     $version_zeroes++;
2364                 }
2365                 next MODULE unless CPAN::Version->vgt($latest, $have);
2366 # to be pedantic we should probably say:
2367 #    && !($have eq "undef" && $latest ne "undef" && $latest gt "");
2368 # to catch the case where CPAN has a version 0 and we have a version undef
2369             } elsif ($what eq "u") {
2370                 next MODULE;
2371             }
2372         } else {
2373             if ($what eq "a") {
2374                 next MODULE;
2375             } elsif ($what eq "r") {
2376                 next MODULE;
2377             } elsif ($what eq "u") {
2378                 $have = "-";
2379             }
2380         }
2381         return if $CPAN::Signal; # this is sometimes lengthy
2382         $seen{$file} ||= 0;
2383         if ($what eq "a") {
2384             push @result, sprintf "%s %s\n", $module->id, $have;
2385         } elsif ($what eq "r") {
2386             push @result, $module->id;
2387             next MODULE if $seen{$file}++;
2388         } elsif ($what eq "u") {
2389             push @result, $module->id;
2390             next MODULE if $seen{$file}++;
2391             next MODULE if $file =~ /^Contact/;
2392         }
2393         unless ($headerdone++){
2394             $CPAN::Frontend->myprint("\n");
2395             $CPAN::Frontend->myprint(sprintf(
2396                                              $sprintf,
2397                                              "",
2398                                              "Package namespace",
2399                                              "",
2400                                              "installed",
2401                                              "latest",
2402                                              "in CPAN file"
2403                                             ));
2404         }
2405         my $color_on = "";
2406         my $color_off = "";
2407         if (
2408             $COLOR_REGISTERED
2409             &&
2410             $CPAN::META->has_inst("Term::ANSIColor")
2411             &&
2412             $module->description
2413            ) {
2414             $color_on = Term::ANSIColor::color("green");
2415             $color_off = Term::ANSIColor::color("reset");
2416         }
2417         $CPAN::Frontend->myprint(sprintf $sprintf,
2418                                  $color_on,
2419                                  $module->id,
2420                                  $color_off,
2421                                  $have,
2422                                  $latest,
2423                                  $file);
2424         $need{$module->id}++;
2425     }
2426     unless (%need) {
2427         if ($what eq "u") {
2428             $CPAN::Frontend->myprint("No modules found for @args\n");
2429         } elsif ($what eq "r") {
2430             $CPAN::Frontend->myprint("All modules are up to date for @args\n");
2431         }
2432     }
2433     if ($what eq "r") {
2434         if ($version_zeroes) {
2435             my $s_has = $version_zeroes > 1 ? "s have" : " has";
2436             $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
2437                 qq{a version number of 0\n});
2438         }
2439         if ($version_undefs) {
2440             my $s_has = $version_undefs > 1 ? "s have" : " has";
2441             $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
2442                 qq{parseable version number\n});
2443         }
2444     }
2445     @result;
2446 }
2447
2448 #-> sub CPAN::Shell::r ;
2449 sub r {
2450     shift->_u_r_common("r",@_);
2451 }
2452
2453 #-> sub CPAN::Shell::u ;
2454 sub u {
2455     shift->_u_r_common("u",@_);
2456 }
2457
2458 #-> sub CPAN::Shell::failed ;
2459 sub failed {
2460     my($self,$only_id,$silent) = @_;
2461     my @failed;
2462   DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
2463         my $failed = "";
2464       NAY: for my $nosayer ( # order matters!
2465                             "unwrapped",
2466                             "writemakefile",
2467                             "signature_verify",
2468                             "make",
2469                             "make_test",
2470                             "install",
2471                             "make_clean",
2472                            ) {
2473             next unless exists $d->{$nosayer};
2474             next unless defined $d->{$nosayer};
2475             next unless (
2476                          UNIVERSAL::can($d->{$nosayer},"failed") ?
2477                          $d->{$nosayer}->failed :
2478                          $d->{$nosayer} =~ /^NO/
2479                         );
2480             next NAY if $only_id && $only_id != (
2481                                                  UNIVERSAL::can($d->{$nosayer},"commandid")
2482                                                  ?
2483                                                  $d->{$nosayer}->commandid
2484                                                  :
2485                                                  $CPAN::CurrentCommandId
2486                                                 );
2487             $failed = $nosayer;
2488             last;
2489         }
2490         next DIST unless $failed;
2491         my $id = $d->id;
2492         $id =~ s|^./../||;
2493         #$print .= sprintf(
2494         #                  "  %-45s: %s %s\n",
2495         push @failed,
2496             (
2497              UNIVERSAL::can($d->{$failed},"failed") ?
2498              [
2499               $d->{$failed}->commandid,
2500               $id,
2501               $failed,
2502               $d->{$failed}->text,
2503               $d->{$failed}{TIME}||0,
2504              ] :
2505              [
2506               1,
2507               $id,
2508               $failed,
2509               $d->{$failed},
2510               0,
2511              ]
2512             );
2513     }
2514     my $scope;
2515     if ($only_id) {
2516         $scope = "this command";
2517     } elsif ($CPAN::Index::HAVE_REANIMATED) {
2518         $scope = "this or a previous session";
2519         # it might be nice to have a section for previous session and
2520         # a second for this
2521     } else {
2522         $scope = "this session";
2523     }
2524     if (@failed) {
2525         my $print;
2526         my $debug = 0;
2527         if ($debug) {
2528             $print = join "",
2529                 map { sprintf "%5d %-45s: %s %s\n", @$_ }
2530                     sort { $a->[0] <=> $b->[0] } @failed;
2531         } else {
2532             $print = join "",
2533                 map { sprintf " %-45s: %s %s\n", @$_[1..3] }
2534                     sort {
2535                         $a->[0] <=> $b->[0]
2536                             ||
2537                                 $a->[4] <=> $b->[4]
2538                        } @failed;
2539         }
2540         $CPAN::Frontend->myprint("Failed during $scope:\n$print");
2541     } elsif (!$only_id || !$silent) {
2542         $CPAN::Frontend->myprint("Nothing failed in $scope\n");
2543     }
2544 }
2545
2546 # XXX intentionally undocumented because completely bogus, unportable,
2547 # useless, etc.
2548
2549 #-> sub CPAN::Shell::status ;
2550 sub status {
2551     my($self) = @_;
2552     require Devel::Size;
2553     my $ps = FileHandle->new;
2554     open $ps, "/proc/$$/status";
2555     my $vm = 0;
2556     while (<$ps>) {
2557         next unless /VmSize:\s+(\d+)/;
2558         $vm = $1;
2559         last;
2560     }
2561     $CPAN::Frontend->mywarn(sprintf(
2562                                     "%-27s %6d\n%-27s %6d\n",
2563                                     "vm",
2564                                     $vm,
2565                                     "CPAN::META",
2566                                     Devel::Size::total_size($CPAN::META)/1024,
2567                                    ));
2568     for my $k (sort keys %$CPAN::META) {
2569         next unless substr($k,0,4) eq "read";
2570         warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
2571         for my $k2 (sort keys %{$CPAN::META->{$k}}) {
2572             warn sprintf "  %-25s %6d (keys: %6d)\n",
2573                 $k2,
2574                     Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
2575                           scalar keys %{$CPAN::META->{$k}{$k2}};
2576         }
2577     }
2578 }
2579
2580 # compare with install_tested
2581 #-> sub CPAN::Shell::is_tested
2582 sub is_tested {
2583     my($self) = @_;
2584     CPAN::Index->reload;
2585     for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
2586         my $time;
2587         if ($CPAN::META->{is_tested}{$b}) {
2588             $time = scalar(localtime $CPAN::META->{is_tested}{$b});
2589         } else {
2590             $time = scalar localtime;
2591             $time =~ s/\S/?/g;
2592         }
2593         $CPAN::Frontend->myprint(sprintf "%s %s\n", $time, $b);
2594     }
2595 }
2596
2597 #-> sub CPAN::Shell::autobundle ;
2598 sub autobundle {
2599     my($self) = shift;
2600     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
2601     my(@bundle) = $self->_u_r_common("a",@_);
2602     my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
2603     File::Path::mkpath($todir);
2604     unless (-d $todir) {
2605         $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
2606         return;
2607     }
2608     my($y,$m,$d) =  (localtime)[5,4,3];
2609     $y+=1900;
2610     $m++;
2611     my($c) = 0;
2612     my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
2613     my($to) = File::Spec->catfile($todir,"$me.pm");
2614     while (-f $to) {
2615         $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
2616         $to = File::Spec->catfile($todir,"$me.pm");
2617     }
2618     my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
2619     $fh->print(
2620                "package Bundle::$me;\n\n",
2621                "\$VERSION = '0.01';\n\n",
2622                "1;\n\n",
2623                "__END__\n\n",
2624                "=head1 NAME\n\n",
2625                "Bundle::$me - Snapshot of installation on ",
2626                $Config::Config{'myhostname'},
2627                " on ",
2628                scalar(localtime),
2629                "\n\n=head1 SYNOPSIS\n\n",
2630                "perl -MCPAN -e 'install Bundle::$me'\n\n",
2631                "=head1 CONTENTS\n\n",
2632                join("\n", @bundle),
2633                "\n\n=head1 CONFIGURATION\n\n",
2634                Config->myconfig,
2635                "\n\n=head1 AUTHOR\n\n",
2636                "This Bundle has been generated automatically ",
2637                "by the autobundle routine in CPAN.pm.\n",
2638               );
2639     $fh->close;
2640     $CPAN::Frontend->myprint("\nWrote bundle file
2641     $to\n\n");
2642 }
2643
2644 #-> sub CPAN::Shell::expandany ;
2645 sub expandany {
2646     my($self,$s) = @_;
2647     CPAN->debug("s[$s]") if $CPAN::DEBUG;
2648     if ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory
2649         $s = CPAN::Distribution->normalize($s);
2650         return $CPAN::META->instance('CPAN::Distribution',$s);
2651         # Distributions spring into existence, not expand
2652     } elsif ($s =~ m|^Bundle::|) {
2653         $self->local_bundles; # scanning so late for bundles seems
2654                               # both attractive and crumpy: always
2655                               # current state but easy to forget
2656                               # somewhere
2657         return $self->expand('Bundle',$s);
2658     } else {
2659         return $self->expand('Module',$s)
2660             if $CPAN::META->exists('CPAN::Module',$s);
2661     }
2662     return;
2663 }
2664
2665 #-> sub CPAN::Shell::expand ;
2666 sub expand {
2667     my $self = shift;
2668     my($type,@args) = @_;
2669     CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
2670     my $class = "CPAN::$type";
2671     my $methods = ['id'];
2672     for my $meth (qw(name)) {
2673         next unless $class->can($meth);
2674         push @$methods, $meth;
2675     }
2676     $self->expand_by_method($class,$methods,@args);
2677 }
2678
2679 #-> sub CPAN::Shell::expand_by_method ;
2680 sub expand_by_method {
2681     my $self = shift;
2682     my($class,$methods,@args) = @_;
2683     my($arg,@m);
2684     for $arg (@args) {
2685         my($regex,$command);
2686         if ($arg =~ m|^/(.*)/$|) {
2687             $regex = $1;
2688         } elsif ($arg =~ m/=/) {
2689             $command = 1;
2690         }
2691         my $obj;
2692         CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
2693                     $class,
2694                     defined $regex ? $regex : "UNDEFINED",
2695                     defined $command ? $command : "UNDEFINED",
2696                    ) if $CPAN::DEBUG;
2697         if (defined $regex) {
2698             if (CPAN::_sqlite_running) {
2699                 $CPAN::SQLite->search($class, $regex);
2700             }
2701             for $obj (
2702                       $CPAN::META->all_objects($class)
2703                      ) {
2704                 unless ($obj && UNIVERSAL::can($obj,"id") && $obj->id){
2705                     # BUG, we got an empty object somewhere
2706                     require Data::Dumper;
2707                     CPAN->debug(sprintf(
2708                                         "Bug in CPAN: Empty id on obj[%s][%s]",
2709                                         $obj,
2710                                         Data::Dumper::Dumper($obj)
2711                                        )) if $CPAN::DEBUG;
2712                     next;
2713                 }
2714                 for my $method (@$methods) {
2715                     my $match = eval {$obj->$method() =~ /$regex/i};
2716                     if ($@) {
2717                         my($err) = $@ =~ /^(.+) at .+? line \d+\.$/;
2718                         $err ||= $@; # if we were too restrictive above
2719                         $CPAN::Frontend->mydie("$err\n");
2720                     } elsif ($match) {
2721                         push @m, $obj;
2722                         last;
2723                     }
2724                 }
2725             }
2726         } elsif ($command) {
2727             die "equal sign in command disabled (immature interface), ".
2728                 "you can set
2729  ! \$CPAN::Shell::ADVANCED_QUERY=1
2730 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
2731 that may go away anytime.\n"
2732                     unless $ADVANCED_QUERY;
2733             my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
2734             my($matchcrit) = $criterion =~ m/^~(.+)/;
2735             for my $self (
2736                           sort
2737                           {$a->id cmp $b->id}
2738                           $CPAN::META->all_objects($class)
2739                          ) {
2740                 my $lhs = $self->$method() or next; # () for 5.00503
2741                 if ($matchcrit) {
2742                     push @m, $self if $lhs =~ m/$matchcrit/;
2743                 } else {
2744                     push @m, $self if $lhs eq $criterion;
2745                 }
2746             }
2747         } else {
2748             my($xarg) = $arg;
2749             if ( $class eq 'CPAN::Bundle' ) {
2750                 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
2751             } elsif ($class eq "CPAN::Distribution") {
2752                 $xarg = CPAN::Distribution->normalize($arg);
2753             } else {
2754                 $xarg =~ s/:+/::/g;
2755             }
2756             if ($CPAN::META->exists($class,$xarg)) {
2757                 $obj = $CPAN::META->instance($class,$xarg);
2758             } elsif ($CPAN::META->exists($class,$arg)) {
2759                 $obj = $CPAN::META->instance($class,$arg);
2760             } else {
2761                 next;
2762             }
2763             push @m, $obj;
2764         }
2765     }
2766     @m = sort {$a->id cmp $b->id} @m;
2767     if ( $CPAN::DEBUG ) {
2768         my $wantarray = wantarray;
2769         my $join_m = join ",", map {$_->id} @m;
2770         $self->debug("wantarray[$wantarray]join_m[$join_m]");
2771     }
2772     return wantarray ? @m : $m[0];
2773 }
2774
2775 #-> sub CPAN::Shell::format_result ;
2776 sub format_result {
2777     my($self) = shift;
2778     my($type,@args) = @_;
2779     @args = '/./' unless @args;
2780     my(@result) = $self->expand($type,@args);
2781     my $result = @result == 1 ?
2782         $result[0]->as_string :
2783             @result == 0 ?
2784                 "No objects of type $type found for argument @args\n" :
2785                     join("",
2786                          (map {$_->as_glimpse} @result),
2787                          scalar @result, " items found\n",
2788                         );
2789     $result;
2790 }
2791
2792 #-> sub CPAN::Shell::report_fh ;
2793 {
2794     my $installation_report_fh;
2795     my $previously_noticed = 0;
2796
2797     sub report_fh {
2798         return $installation_report_fh if $installation_report_fh;
2799         if ($CPAN::META->has_inst("File::Temp")) {
2800             $installation_report_fh
2801                 = File::Temp->new(
2802                                   template => 'cpan_install_XXXX',
2803                                   suffix   => '.txt',
2804                                   unlink   => 0,
2805                                  );
2806         }
2807         unless ( $installation_report_fh ) {
2808             warn("Couldn't open installation report file; " .
2809                  "no report file will be generated."
2810                 ) unless $previously_noticed++;
2811         }
2812     }
2813 }
2814
2815
2816 # The only reason for this method is currently to have a reliable
2817 # debugging utility that reveals which output is going through which
2818 # channel. No, I don't like the colors ;-)
2819
2820 # to turn colordebugging on, write
2821 # cpan> o conf colorize_output 1
2822
2823 #-> sub CPAN::Shell::print_ornamented ;
2824 {
2825     my $print_ornamented_have_warned = 0;
2826     sub colorize_output {
2827         my $colorize_output = $CPAN::Config->{colorize_output};
2828         if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
2829             unless ($print_ornamented_have_warned++) {
2830                 # no myprint/mywarn within myprint/mywarn!
2831                 warn "Colorize_output is set to true but Term::ANSIColor is not
2832 installed. To activate colorized output, please install Term::ANSIColor.\n\n";
2833             }
2834             $colorize_output = 0;
2835         }
2836         return $colorize_output;
2837     }
2838 }
2839
2840
2841 #-> sub CPAN::Shell::print_ornamented ;
2842 sub print_ornamented {
2843     my($self,$what,$ornament) = @_;
2844     return unless defined $what;
2845
2846     local $| = 1; # Flush immediately
2847     if ( $CPAN::Be_Silent ) {
2848         print {report_fh()} $what;
2849         return;
2850     }
2851     my $swhat = "$what"; # stringify if it is an object
2852     if ($CPAN::Config->{term_is_latin}){
2853         # courtesy jhi:
2854         $swhat
2855             =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
2856     }
2857     if ($self->colorize_output) {
2858         if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
2859             # if you want to have this configurable, please file a bugreport
2860             $ornament = $CPAN::Config->{colorize_debug} || "black on_cyan";
2861         }
2862         my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
2863         if ($@) {
2864             print "Term::ANSIColor rejects color[$ornament]: $@\n
2865 Please choose a different color (Hint: try 'o conf init /color/')\n";
2866         }
2867         print $color_on,
2868             $swhat,
2869                 Term::ANSIColor::color("reset");
2870     } else {
2871         print $swhat;
2872     }
2873 }
2874
2875 #-> sub CPAN::Shell::myprint ;
2876
2877 # where is myprint/mywarn/Frontend/etc. documented? We need guidelines
2878 # where to use what! I think, we send everything to STDOUT and use
2879 # print for normal/good news and warn for news that need more
2880 # attention. Yes, this is our working contract for now.
2881 sub myprint {
2882     my($self,$what) = @_;
2883
2884     $self->print_ornamented($what, $CPAN::Config->{colorize_print}||'bold blue on_white');
2885 }
2886
2887 #-> sub CPAN::Shell::myexit ;
2888 sub myexit {
2889     my($self,$what) = @_;
2890     $self->myprint($what);
2891     exit;
2892 }
2893
2894 #-> sub CPAN::Shell::mywarn ;
2895 sub mywarn {
2896     my($self,$what) = @_;
2897     $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
2898 }
2899
2900 # only to be used for shell commands
2901 #-> sub CPAN::Shell::mydie ;
2902 sub mydie {
2903     my($self,$what) = @_;
2904     $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
2905
2906     # If it is the shell, we want that the following die to be silent,
2907     # but if it is not the shell, we would need a 'die $what'. We need
2908     # to take care that only shell commands use mydie. Is this
2909     # possible?
2910
2911     die "\n";
2912 }
2913
2914 # sub CPAN::Shell::colorable_makemaker_prompt ;
2915 sub colorable_makemaker_prompt {
2916     my($foo,$bar) = @_;
2917     if (CPAN::Shell->colorize_output) {
2918         my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
2919         my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
2920         print $color_on;
2921     }
2922     my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
2923     if (CPAN::Shell->colorize_output) {
2924         print Term::ANSIColor::color('reset');
2925     }
2926     return $ans;
2927 }
2928
2929 # use this only for unrecoverable errors!
2930 #-> sub CPAN::Shell::unrecoverable_error ;
2931 sub unrecoverable_error {
2932     my($self,$what) = @_;
2933     my @lines = split /\n/, $what;
2934     my $longest = 0;
2935     for my $l (@lines) {
2936         $longest = length $l if length $l > $longest;
2937     }
2938     $longest = 62 if $longest > 62;
2939     for my $l (@lines) {
2940         if ($l =~ /^\s*$/){
2941             $l = "\n";
2942             next;
2943         }
2944         $l = "==> $l";
2945         if (length $l < 66) {
2946             $l = pack "A66 A*", $l, "<==";
2947         }
2948         $l .= "\n";
2949     }
2950     unshift @lines, "\n";
2951     $self->mydie(join "", @lines);
2952 }
2953
2954 #-> sub CPAN::Shell::mysleep ;
2955 sub mysleep {
2956     my($self, $sleep) = @_;
2957     use Time::HiRes qw(sleep);
2958     sleep $sleep;
2959 }
2960
2961 #-> sub CPAN::Shell::setup_output ;
2962 sub setup_output {
2963     return if -t STDOUT;
2964     my $odef = select STDERR;
2965     $| = 1;
2966     select STDOUT;
2967     $| = 1;
2968     select $odef;
2969 }
2970
2971 #-> sub CPAN::Shell::rematein ;
2972 # RE-adme||MA-ke||TE-st||IN-stall : nearly everything runs through here
2973 sub rematein {
2974     my $self = shift;
2975     my($meth,@some) = @_;
2976     my @pragma;
2977     while($meth =~ /^(ff?orce|notest)$/) {
2978         push @pragma, $meth;
2979         $meth = shift @some or
2980             $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
2981                                    "cannot continue");
2982     }
2983     setup_output();
2984     CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
2985
2986     # Here is the place to set "test_count" on all involved parties to
2987     # 0. We then can pass this counter on to the involved
2988     # distributions and those can refuse to test if test_count > X. In
2989     # the first stab at it we could use a 1 for "X".
2990
2991     # But when do I reset the distributions to start with 0 again?
2992     # Jost suggested to have a random or cycling interaction ID that
2993     # we pass through. But the ID is something that is just left lying
2994     # around in addition to the counter, so I'd prefer to set the
2995     # counter to 0 now, and repeat at the end of the loop. But what
2996     # about dependencies? They appear later and are not reset, they
2997     # enter the queue but not its copy. How do they get a sensible
2998     # test_count?
2999
3000     my $needs_recursion_protection = "make|test|install";
3001
3002     # construct the queue
3003     my($s,@s,@qcopy);
3004   STHING: foreach $s (@some) {
3005         my $obj;
3006         if (ref $s) {
3007             CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
3008             $obj = $s;
3009         } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
3010         } elsif ($s =~ m|^/|) { # looks like a regexp
3011             if (substr($s,-1,1) eq ".") {
3012                 $obj = CPAN::Shell->expandany($s);
3013             } else {
3014                 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
3015                                         "not supported.\nRejecting argument '$s'\n");
3016                 $CPAN::Frontend->mysleep(2);
3017                 next;
3018             }
3019         } elsif ($meth eq "ls") {
3020             $self->globls($s,\@pragma);
3021             next STHING;
3022         } else {
3023             CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
3024             $obj = CPAN::Shell->expandany($s);
3025         }
3026         if (0) {
3027         } elsif (ref $obj) {
3028             if ($meth =~ /^($needs_recursion_protection)$/) {
3029                 # it would be silly to check for recursion for look or dump
3030                 # (we are in CPAN::Shell::rematein)
3031                 CPAN->debug("Going to test against recursion") if $CPAN::DEBUG;
3032                 eval {  $obj->color_cmd_tmps(0,1); };
3033                 if ($@){
3034                     if (ref $@
3035                         and $@->isa("CPAN::Exception::RecursiveDependency")) {
3036                         $CPAN::Frontend->mywarn($@);
3037                     } else {
3038                         if (0) {
3039                             require Carp;
3040                             Carp::confess(sprintf "DEBUG: \$\@[%s]ref[%s]", $@, ref $@);
3041                         }
3042                         die;
3043                     }
3044                 }
3045             }
3046             CPAN::Queue->new(qmod => $obj->id, reqtype => "c");
3047             push @qcopy, $obj;
3048         } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
3049             $obj = $CPAN::META->instance('CPAN::Author',uc($s));
3050             if ($meth =~ /^(dump|ls)$/) {
3051                 $obj->$meth();
3052             } else {
3053                 $CPAN::Frontend->mywarn(
3054                                         join "",
3055                                         "Don't be silly, you can't $meth ",
3056                                         $obj->fullname,
3057                                         " ;-)\n"
3058                                        );
3059                 $CPAN::Frontend->mysleep(2);
3060             }
3061         } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
3062             CPAN::InfoObj->dump($s);
3063         } else {
3064             $CPAN::Frontend
3065                 ->mywarn(qq{Warning: Cannot $meth $s, }.
3066                           qq{don't know what it is.
3067 Try the command
3068
3069     i /$s/
3070
3071 to find objects with matching identifiers.
3072 });
3073             $CPAN::Frontend->mysleep(2);
3074         }
3075     }
3076
3077     # queuerunner (please be warned: when I started to change the
3078     # queue to hold objects instead of names, I made one or two
3079     # mistakes and never found which. I reverted back instead)
3080     while (my $q = CPAN::Queue->first) {
3081         my $obj;
3082         my $s = $q->as_string;
3083         my $reqtype = $q->reqtype || "";
3084         $obj = CPAN::Shell->expandany($s);
3085         unless ($obj) {
3086             # don't know how this can happen, maybe we should panic,
3087             # but maybe we get a solution from the first user who hits
3088             # this unfortunate exception?
3089             $CPAN::Frontend->mywarn("Warning: Could not expand string '$s' ".
3090                                     "to an object. Skipping.\n");
3091             $CPAN::Frontend->mysleep(5);
3092             CPAN::Queue->delete_first($s);
3093             next;
3094         }
3095         $obj->{reqtype} ||= "";
3096         {
3097             # force debugging because CPAN::SQLite somehow delivers us
3098             # an empty object;
3099
3100             # local $CPAN::DEBUG = 1024; # Shell; probably fixed now
3101
3102             CPAN->debug("s[$s]obj-reqtype[$obj->{reqtype}]".
3103                         "q-reqtype[$reqtype]") if $CPAN::DEBUG;
3104         }
3105         if ($obj->{reqtype}) {
3106             if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
3107                 $obj->{reqtype} = $reqtype;
3108                 if (
3109                     exists $obj->{install}
3110                     &&
3111                     (
3112                      UNIVERSAL::can($obj->{install},"failed") ?
3113                      $obj->{install}->failed :
3114                      $obj->{install} =~ /^NO/
3115                     )
3116                    ) {
3117                     delete $obj->{install};
3118                     $CPAN::Frontend->mywarn
3119                         ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
3120                 }
3121             }
3122         } else {
3123             $obj->{reqtype} = $reqtype;
3124         }
3125
3126         for my $pragma (@pragma) {
3127             if ($pragma
3128                 &&
3129                 $obj->can($pragma)){
3130                 $obj->$pragma($meth);
3131             }
3132         }
3133         if (UNIVERSAL::can($obj, 'called_for')) {
3134             $obj->called_for($s);
3135         }
3136         CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
3137                     qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
3138
3139         push @qcopy, $obj;
3140         if (! UNIVERSAL::can($obj,$meth)) {
3141             # Must never happen
3142             my $serialized = "";
3143             if (0) {
3144             } elsif ($CPAN::META->has_inst("YAML::Syck")) {
3145                 $serialized = YAML::Syck::Dump($obj);
3146             } elsif ($CPAN::META->has_inst("YAML")) {
3147                 $serialized = YAML::Dump($obj);
3148             } elsif ($CPAN::META->has_inst("Data::Dumper")) {
3149                 $serialized = Data::Dumper::Dumper($obj);
3150             } else {
3151                 require overload;
3152                 $serialized = overload::StrVal($obj);
3153             }
3154             $CPAN::Frontend->mydie("Panic: obj[$serialized] cannot meth[$meth]");
3155         } elsif ($obj->$meth()){
3156             CPAN::Queue->delete($s);
3157         } else {
3158             CPAN->debug("failed");
3159         }
3160
3161         $obj->undelay;
3162         for my $pragma (@pragma) {
3163             my $unpragma = "un$pragma";
3164             if ($obj->can($unpragma)) {
3165                 $obj->$unpragma();
3166             }
3167         }
3168         CPAN::Queue->delete_first($s);
3169     }
3170     if ($meth =~ /^($needs_recursion_protection)$/) {
3171         for my $obj (@qcopy) {
3172             $obj->color_cmd_tmps(0,0);
3173         }
3174     }
3175 }
3176
3177 #-> sub CPAN::Shell::recent ;
3178 sub recent {
3179   my($self) = @_;
3180
3181   CPAN::Distribution::_display_url( $self, $CPAN::Defaultrecent );
3182   return;
3183 }
3184
3185 {
3186     # set up the dispatching methods
3187     no strict "refs";
3188     for my $command (qw(
3189                         clean
3190                         cvs_import
3191                         dump
3192                         force
3193                         fforce
3194                         get
3195                         install
3196                         look
3197                         ls
3198                         make
3199                         notest
3200                         perldoc
3201                         readme
3202                         test
3203                        )) {
3204         *$command = sub { shift->rematein($command, @_); };
3205     }
3206 }
3207
3208 package CPAN::LWP::UserAgent;
3209 use strict;
3210
3211 sub config {
3212     return if $SETUPDONE;
3213     if ($CPAN::META->has_usable('LWP::UserAgent')) {
3214         require LWP::UserAgent;
3215         @ISA = qw(Exporter LWP::UserAgent);
3216         $SETUPDONE++;
3217     } else {
3218         $CPAN::Frontend->mywarn("  LWP::UserAgent not available\n");
3219     }
3220 }
3221
3222 sub get_basic_credentials {
3223     my($self, $realm, $uri, $proxy) = @_;
3224     if ($USER && $PASSWD) {
3225         return ($USER, $PASSWD);
3226     }
3227     if ( $proxy ) {
3228         ($USER,$PASSWD) = $self->get_proxy_credentials();
3229     } else {
3230         ($USER,$PASSWD) = $self->get_non_proxy_credentials();
3231     }
3232     return($USER,$PASSWD);
3233 }
3234
3235 sub get_proxy_credentials {
3236     my $self = shift;
3237     my ($user, $password);
3238     if ( defined $CPAN::Config->{proxy_user} &&
3239          defined $CPAN::Config->{proxy_pass}) {
3240         $user = $CPAN::Config->{proxy_user};
3241         $password = $CPAN::Config->{proxy_pass};
3242         return ($user, $password);
3243     }
3244     my $username_prompt = "\nProxy authentication needed!
3245  (Note: to permanently configure username and password run
3246    o conf proxy_user your_username
3247    o conf proxy_pass your_password
3248      )\nUsername:";
3249     ($user, $password) =
3250         _get_username_and_password_from_user($username_prompt);
3251     return ($user,$password);
3252 }
3253
3254 sub get_non_proxy_credentials {
3255     my $self = shift;
3256     my ($user,$password);
3257     if ( defined $CPAN::Config->{username} &&
3258          defined $CPAN::Config->{password}) {
3259         $user = $CPAN::Config->{username};
3260         $password = $CPAN::Config->{password};
3261         return ($user, $password);
3262     }
3263     my $username_prompt = "\nAuthentication needed!
3264      (Note: to permanently configure username and password run
3265        o conf username your_username
3266        o conf password your_password
3267      )\nUsername:";
3268
3269     ($user, $password) =
3270         _get_username_and_password_from_user($username_prompt);
3271     return ($user,$password);
3272 }
3273
3274 sub _get_username_and_password_from_user {
3275     my $username_message = shift;
3276     my ($username,$password);
3277
3278     ExtUtils::MakeMaker->import(qw(prompt));
3279     $username = prompt($username_message);
3280         if ($CPAN::META->has_inst("Term::ReadKey")) {
3281             Term::ReadKey::ReadMode("noecho");
3282         }
3283     else {
3284         $CPAN::Frontend->mywarn(
3285             "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"
3286         );
3287     }
3288     $password = prompt("Password:");
3289
3290         if ($CPAN::META->has_inst("Term::ReadKey")) {
3291             Term::ReadKey::ReadMode("restore");
3292         }
3293         $CPAN::Frontend->myprint("\n\n");
3294     return ($username,$password);
3295 }
3296
3297 # mirror(): Its purpose is to deal with proxy authentication. When we
3298 # call SUPER::mirror, we relly call the mirror method in
3299 # LWP::UserAgent. LWP::UserAgent will then call
3300 # $self->get_basic_credentials or some equivalent and this will be
3301 # $self->dispatched to our own get_basic_credentials method.
3302
3303 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3304
3305 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3306 # although we have gone through our get_basic_credentials, the proxy
3307 # server refuses to connect. This could be a case where the username or
3308 # password has changed in the meantime, so I'm trying once again without
3309 # $USER and $PASSWD to give the get_basic_credentials routine another
3310 # chance to set $USER and $PASSWD.
3311
3312 # mirror(): Its purpose is to deal with proxy authentication. When we
3313 # call SUPER::mirror, we relly call the mirror method in
3314 # LWP::UserAgent. LWP::UserAgent will then call
3315 # $self->get_basic_credentials or some equivalent and this will be
3316 # $self->dispatched to our own get_basic_credentials method.
3317
3318 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3319
3320 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3321 # although we have gone through our get_basic_credentials, the proxy
3322 # server refuses to connect. This could be a case where the username or
3323 # password has changed in the meantime, so I'm trying once again without
3324 # $USER and $PASSWD to give the get_basic_credentials routine another
3325 # chance to set $USER and $PASSWD.
3326
3327 sub mirror {
3328     my($self,$url,$aslocal) = @_;
3329     my $result = $self->SUPER::mirror($url,$aslocal);
3330     if ($result->code == 407) {
3331         undef $USER;
3332         undef $PASSWD;
3333         $result = $self->SUPER::mirror($url,$aslocal);
3334     }
3335     $result;
3336 }
3337
3338 package CPAN::FTP;
3339 use strict;
3340
3341 #-> sub CPAN::FTP::ftp_statistics
3342 # if they want to rewrite, they need to pass in a filehandle
3343 sub _ftp_statistics {
3344     my($self,$fh) = @_;
3345     my $locktype = $fh ? LOCK_EX : LOCK_SH;
3346     $fh ||= FileHandle->new;
3347     my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3348     open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!");
3349     my $sleep = 1;
3350     my $waitstart;
3351     while (!flock $fh, $locktype|LOCK_NB) {
3352         $waitstart ||= localtime();
3353         if ($sleep>3) {
3354             $CPAN::Frontend->mywarn("Waiting for a read lock on '$file' (since $waitstart)\n");
3355         }
3356         $CPAN::Frontend->mysleep($sleep);
3357         if ($sleep <= 3) {
3358             $sleep+=0.33;
3359         } elsif ($sleep <=6) {
3360             $sleep+=0.11;
3361         }
3362     }
3363     my $stats = eval { CPAN->_yaml_loadfile($file); };
3364     if ($@) {
3365         if (ref $@) {
3366             if (ref $@ eq "CPAN::Exception::yaml_not_installed") {
3367                 $CPAN::Frontend->myprint("Warning (usually harmless): $@");
3368                 return;
3369             } elsif (ref $@ eq "CPAN::Exception::yaml_process_error") {
3370                 $CPAN::Frontend->mydie($@);
3371             }
3372         } else {
3373             $CPAN::Frontend->mydie($@);
3374         }
3375     }
3376     return $stats->[0];
3377 }
3378
3379 #-> sub CPAN::FTP::_mytime
3380 sub _mytime () {
3381     if (CPAN->has_inst("Time::HiRes")) {
3382         return Time::HiRes::time();
3383     } else {
3384         return time;
3385     }
3386 }
3387
3388 #-> sub CPAN::FTP::_new_stats
3389 sub _new_stats {
3390     my($self,$file) = @_;
3391     my $ret = {
3392                file => $file,
3393                attempts => [],
3394                start => _mytime,
3395               };
3396     $ret;
3397 }
3398
3399 #-> sub CPAN::FTP::_add_to_statistics
3400 sub _add_to_statistics {
3401     my($self,$stats) = @_;
3402     my $yaml_module = CPAN::_yaml_module;
3403     $self->debug("yaml_module[$yaml_module]") if $CPAN::DEBUG;
3404     if ($CPAN::META->has_inst($yaml_module)) {
3405         $stats->{thesiteurl} = $ThesiteURL;
3406         if (CPAN->has_inst("Time::HiRes")) {
3407             $stats->{end} = Time::HiRes::time();
3408         } else {
3409             $stats->{end} = time;
3410         }
3411         my $fh = FileHandle->new;
3412         my $time = time;
3413         my $sdebug = 0;
3414         my @debug;
3415         @debug = $time if $sdebug;
3416         my $fullstats = $self->_ftp_statistics($fh);
3417         close $fh;
3418         $fullstats->{history} ||= [];
3419         push @debug, scalar @{$fullstats->{history}} if $sdebug;
3420         push @debug, time if $sdebug;
3421         push @{$fullstats->{history}}, $stats;
3422         # arbitrary hardcoded constants until somebody demands to have
3423         # them settable; YAML.pm 0.62 is unacceptably slow with 999;
3424         # YAML::Syck 0.82 has no noticable performance problem with 999;
3425         while (
3426                @{$fullstats->{history}} > 99
3427                || $time - $fullstats->{history}[0]{start} > 14*86400
3428               ) {
3429             shift @{$fullstats->{history}}
3430         }
3431         push @debug, scalar @{$fullstats->{history}} if $sdebug;
3432         push @debug, time if $sdebug;
3433         push @debug, scalar localtime($fullstats->{history}[0]{start}) if $sdebug;
3434         # need no eval because if this fails, it is serious
3435         my $sfile = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3436         CPAN->_yaml_dumpfile("$sfile.$$",$fullstats);
3437         if ( $sdebug ) {
3438             local $CPAN::DEBUG = 512; # FTP
3439             push @debug, time;
3440             CPAN->debug(sprintf("DEBUG history: before_read[%d]before[%d]at[%d]".
3441                                 "after[%d]at[%d]oldest[%s]dumped backat[%d]",
3442                                 @debug,
3443                                ));
3444         }
3445         # Win32 cannot rename a file to an existing filename
3446         unlink($sfile) if ($^O eq 'MSWin32');
3447         rename "$sfile.$$", $sfile
3448             or $CPAN::Frontend->mydie("Could not rename '$sfile.$$' to '$sfile': $!\n");
3449     }
3450 }
3451
3452 # if file is CHECKSUMS, suggest the place where we got the file to be
3453 # checked from, maybe only for young files?
3454 #-> sub CPAN::FTP::_recommend_url_for
3455 sub _recommend_url_for {
3456     my($self, $file) = @_;
3457     my $urllist = $self->_get_urllist;
3458     if ($file =~ s|/CHECKSUMS(.gz)?$||) {
3459         my $fullstats = $self->_ftp_statistics();
3460         my $history = $fullstats->{history} || [];
3461         while (my $last = pop @$history) {
3462             last if $last->{end} - time > 3600; # only young results are interesting
3463             next unless $last->{file}; # dirname of nothing dies!
3464             next unless $file eq File::Basename::dirname($last->{file});
3465             return $last->{thesiteurl};
3466         }
3467     }
3468     if ($CPAN::Config->{randomize_urllist}
3469         &&
3470         rand(1) < $CPAN::Config->{randomize_urllist}
3471        ) {
3472         $urllist->[int rand scalar @$urllist];
3473     } else {
3474         return ();
3475     }
3476 }
3477
3478 #-> sub CPAN::FTP::_get_urllist
3479 sub _get_urllist {
3480     my($self) = @_;
3481     $CPAN::Config->{urllist} ||= [];
3482     unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
3483         $CPAN::Frontend->mywarn("Malformed urllist; ignoring.  Configuration file corrupt?\n");
3484         $CPAN::Config->{urllist} = [];
3485     }
3486     my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}};
3487     for my $u (@urllist) {
3488         CPAN->debug("u[$u]") if $CPAN::DEBUG;
3489         if (UNIVERSAL::can($u,"text")) {
3490             $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
3491         } else {
3492             $u .= "/" unless substr($u,-1) eq "/";
3493             $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
3494         }
3495     }
3496     \@urllist;
3497 }
3498
3499 #-> sub CPAN::FTP::ftp_get ;
3500 sub ftp_get {
3501     my($class,$host,$dir,$file,$target) = @_;
3502     $class->debug(
3503                   qq[Going to fetch file [$file] from dir [$dir]
3504         on host [$host] as local [$target]\n]
3505                  ) if $CPAN::DEBUG;
3506     my $ftp = Net::FTP->new($host);
3507     unless ($ftp) {
3508         $CPAN::Frontend->mywarn("  Could not connect to host '$host' with Net::FTP\n");
3509         return;
3510     }
3511     return 0 unless defined $ftp;
3512     $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
3513     $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
3514     unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
3515         my $msg = $ftp->message;
3516         $CPAN::Frontend->mywarn("  Couldn't login on $host: $msg");
3517         return;
3518     }
3519     unless ( $ftp->cwd($dir) ){
3520         my $msg = $ftp->message;
3521         $CPAN::Frontend->mywarn("  Couldn't cwd $dir: $msg");
3522         return;
3523     }
3524     $ftp->binary;
3525     $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
3526     unless ( $ftp->get($file,$target) ){
3527         my $msg = $ftp->message;
3528         $CPAN::Frontend->mywarn("  Couldn't fetch $file from $host: $msg");
3529         return;
3530     }
3531     $ftp->quit; # it's ok if this fails
3532     return 1;
3533 }
3534
3535 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
3536
3537  # > *** /install/perl/live/lib/CPAN.pm-        Wed Sep 24 13:08:48 1997
3538  # > --- /tmp/cp        Wed Sep 24 13:26:40 1997
3539  # > ***************
3540  # > *** 1562,1567 ****
3541  # > --- 1562,1580 ----
3542  # >       return 1 if substr($url,0,4) eq "file";
3543  # >       return 1 unless $url =~ m|://([^/]+)|;
3544  # >       my $host = $1;
3545  # > +     my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
3546  # > +     if ($proxy) {
3547  # > +         $proxy =~ m|://([^/:]+)|;
3548  # > +         $proxy = $1;
3549  # > +         my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
3550  # > +         if ($noproxy) {
3551  # > +             if ($host !~ /$noproxy$/) {
3552  # > +                 $host = $proxy;
3553  # > +             }
3554  # > +         } else {
3555  # > +             $host = $proxy;
3556  # > +         }
3557  # > +     }
3558  # >       require Net::Ping;
3559  # >       return 1 unless $Net::Ping::VERSION >= 2;
3560  # >       my $p;
3561
3562
3563 #-> sub CPAN::FTP::localize ;
3564 sub localize {
3565     my($self,$file,$aslocal,$force) = @_;
3566     $force ||= 0;
3567     Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
3568         unless defined $aslocal;
3569     $self->debug("file[$file] aslocal[$aslocal] force[$force]")
3570         if $CPAN::DEBUG;
3571
3572     if ($^O eq 'MacOS') {
3573         # Comment by AK on 2000-09-03: Uniq short filenames would be
3574         # available in CHECKSUMS file
3575         my($name, $path) = File::Basename::fileparse($aslocal, '');
3576         if (length($name) > 31) {
3577             $name =~ s/(
3578                         \.(
3579                            readme(\.(gz|Z))? |
3580                            (tar\.)?(gz|Z) |
3581                            tgz |
3582                            zip |
3583                            pm\.(gz|Z)
3584                           )
3585                        )$//x;
3586             my $suf = $1;
3587             my $size = 31 - length($suf);
3588             while (length($name) > $size) {
3589                 chop $name;
3590             }
3591             $name .= $suf;
3592             $aslocal = File::Spec->catfile($path, $name);
3593         }
3594     }
3595
3596     if (-f $aslocal && -r _ && !($force & 1)){
3597         my $size;
3598         if ($size = -s $aslocal) {
3599             $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
3600             return $aslocal;
3601         } else {
3602             # empty file from a previous unsuccessful attempt to download it
3603             unlink $aslocal or
3604                 $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
3605                                        "could not remove.");
3606         }
3607     }
3608     my($maybe_restore) = 0;
3609     if (-f $aslocal){
3610         rename $aslocal, "$aslocal.bak$$";
3611         $maybe_restore++;
3612     }
3613
3614     my($aslocal_dir) = File::Basename::dirname($aslocal);
3615     File::Path::mkpath($aslocal_dir);
3616     $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
3617         qq{directory "$aslocal_dir".
3618     I\'ll continue, but if you encounter problems, they may be due
3619     to insufficient permissions.\n}) unless -w $aslocal_dir;
3620
3621     # Inheritance is not easier to manage than a few if/else branches
3622     if ($CPAN::META->has_usable('LWP::UserAgent')) {
3623         unless ($Ua) {
3624             CPAN::LWP::UserAgent->config;
3625             eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
3626             if ($@) {
3627                 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
3628                     if $CPAN::DEBUG;
3629             } else {
3630                 my($var);
3631                 $Ua->proxy('ftp',  $var)
3632                     if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
3633                 $Ua->proxy('http', $var)
3634                     if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
3635
3636
3637 # >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
3638 #
3639 #  > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
3640 #  > use ones that require basic autorization.
3641 #
3642 #  > Example of when I use it manually in my own stuff:
3643 #
3644 #  > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
3645 #  > $req->proxy_authorization_basic("username","password");
3646 #  > $res = $ua->request($req);
3647 #
3648
3649                 $Ua->no_proxy($var)
3650                     if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
3651             }
3652         }
3653     }
3654     for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
3655         $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
3656     }
3657
3658     # Try the list of urls for each single object. We keep a record
3659     # where we did get a file from
3660     my(@reordered,$last);
3661     my $ccurllist = $self->_get_urllist;
3662     $last = $#$ccurllist;
3663     if ($force & 2) { # local cpans probably out of date, don't reorder
3664         @reordered = (0..$last);
3665     } else {
3666         @reordered =
3667             sort {
3668                 (substr($ccurllist->[$b],0,4) eq "file")
3669                     <=>
3670                 (substr($ccurllist->[$a],0,4) eq "file")
3671                     or
3672                 defined($ThesiteURL)
3673                     and
3674                 ($ccurllist->[$b] eq $ThesiteURL)
3675                     <=>
3676                 ($ccurllist->[$a] eq $ThesiteURL)
3677             } 0..$last;
3678     }
3679     my(@levels);
3680     $Themethod ||= "";
3681     $self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG;
3682     if ($Themethod) {
3683         @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
3684     } else {
3685         @levels = qw/easy hard hardest/;
3686     }
3687     @levels = qw/easy/ if $^O eq 'MacOS';
3688     my($levelno);
3689     local $ENV{FTP_PASSIVE} =
3690         exists $CPAN::Config->{ftp_passive} ?
3691         $CPAN::Config->{ftp_passive} : 1;
3692     my $ret;
3693     my $stats = $self->_new_stats($file);
3694   LEVEL: for $levelno (0..$#levels) {
3695         my $level = $levels[$levelno];
3696         my $method = "host$level";
3697         my @host_seq = $level eq "easy" ?
3698             @reordered : 0..$last;  # reordered has CDROM up front
3699         my @urllist = map { $ccurllist->[$_] } @host_seq;
3700         for my $u (@CPAN::Defaultsites) {
3701             push @urllist, $u unless grep { $_ eq $u } @urllist;
3702         }
3703         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
3704         my $aslocal_tempfile = $aslocal . ".tmp" . $$;
3705         if (my $recommend = $self->_recommend_url_for($file)) {
3706             @urllist = grep { $_ ne $recommend } @urllist;
3707             unshift @urllist, $recommend;
3708         }
3709         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
3710         $ret = $self->$method(\@urllist,$file,$aslocal_tempfile,$stats);
3711         if ($ret) {
3712             CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG;
3713             if ($ret eq $aslocal_tempfile) {
3714                 # if we got it exactly as we asked for, only then we
3715                 # want to rename
3716                 rename $aslocal_tempfile, $aslocal
3717                     or $CPAN::Frontend->mydie("Error while trying to rename ".
3718                                               "'$ret' to '$aslocal': $!");
3719                 $ret = $aslocal;
3720             }
3721             $Themethod = $level;
3722             my $now = time;
3723             # utime $now, $now, $aslocal; # too bad, if we do that, we
3724                                           # might alter a local mirror
3725             $self->debug("level[$level]") if $CPAN::DEBUG;
3726             last LEVEL;
3727         } else {
3728             unlink $aslocal_tempfile;
3729             last if $CPAN::Signal; # need to cleanup
3730         }
3731     }
3732     if ($ret) {
3733         $stats->{filesize} = -s $ret;
3734     }
3735     $self->debug("before _add_to_statistics") if $CPAN::DEBUG;
3736     $self->_add_to_statistics($stats);
3737     $self->debug("after _add_to_statistics") if $CPAN::DEBUG;
3738     if ($ret) {
3739         unlink "$aslocal.bak$$";
3740         return $ret;
3741     }
3742     unless ($CPAN::Signal) {
3743         my(@mess);
3744         local $" = " ";
3745         if (@{$CPAN::Config->{urllist}}) {
3746             push @mess,
3747                 qq{Please check, if the URLs I found in your configuration file \(}.
3748                     join(", ", @{$CPAN::Config->{urllist}}).
3749                         qq{\) are valid.};
3750         } else {
3751             push @mess, qq{Your urllist is empty!};
3752         }
3753         push @mess, qq{The urllist can be edited.},
3754             qq{E.g. with 'o conf urllist push ftp://myurl/'};
3755         $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
3756         $CPAN::Frontend->mywarn("Could not fetch $file\n");
3757         $CPAN::Frontend->mysleep(2);
3758     }
3759     if ($maybe_restore) {
3760         rename "$aslocal.bak$$", $aslocal;
3761         $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
3762                                  $self->ls($aslocal));
3763         return $aslocal;
3764     }
3765     return;
3766 }
3767
3768 sub _set_attempt {
3769     my($self,$stats,$method,$url) = @_;
3770     push @{$stats->{attempts}}, {
3771                                  method => $method,
3772                                  start => _mytime,
3773                                  url => $url,
3774                                 };
3775 }
3776
3777 # package CPAN::FTP;
3778 sub hosteasy {
3779     my($self,$host_seq,$file,$aslocal,$stats) = @_;
3780     my($ro_url);
3781   HOSTEASY: for $ro_url (@$host_seq) {
3782         $self->_set_attempt($stats,"easy",$ro_url);
3783         my $url .= "$ro_url$file";
3784         $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
3785         if ($url =~ /^file:/) {
3786             my $l;
3787             if ($CPAN::META->has_inst('URI::URL')) {
3788                 my $u =  URI::URL->new($url);
3789                 $l = $u->path;
3790             } else { # works only on Unix, is poorly constructed, but
3791                 # hopefully better than nothing.
3792                 # RFC 1738 says fileurl BNF is
3793                 # fileurl = "file://" [ host | "localhost" ] "/" fpath
3794                 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
3795                 # the code
3796                 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
3797                 $l =~ s|^file:||;                   # assume they
3798                                                     # meant
3799                                                     # file://localhost
3800                 $l =~ s|^/||s
3801                     if ! -f $l && $l =~ m|^/\w:|;   # e.g. /P:
3802             }
3803             $self->debug("local file[$l]") if $CPAN::DEBUG;
3804             if ( -f $l && -r _) {
3805                 $ThesiteURL = $ro_url;
3806                 return $l;
3807             }
3808             if ($l =~ /(.+)\.gz$/) {
3809                 my $ungz = $1;
3810                 if ( -f $ungz && -r _) {
3811                     $ThesiteURL = $ro_url;
3812                     return $ungz;
3813                 }
3814             }
3815             # Maybe mirror has compressed it?
3816             if (-f "$l.gz") {
3817                 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
3818                 eval { CPAN::Tarzip->new("$l.gz")->gunzip($aslocal) };
3819                 if ( -f $aslocal) {
3820                     $ThesiteURL = $ro_url;
3821                     return $aslocal;
3822                 }
3823             }
3824         }
3825         $self->debug("it was not a file URL") if $CPAN::DEBUG;
3826         if ($CPAN::META->has_usable('LWP')) {
3827             $CPAN::Frontend->myprint("Fetching with LWP:
3828   $url
3829 ");
3830             unless ($Ua) {
3831                 CPAN::LWP::UserAgent->config;
3832                 eval { $Ua = CPAN::LWP::UserAgent->new; };
3833                 if ($@) {
3834                     $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
3835                 }
3836             }
3837             my $res = $Ua->mirror($url, $aslocal);
3838             if ($res->is_success) {
3839                 $ThesiteURL = $ro_url;
3840                 my $now = time;
3841                 utime $now, $now, $aslocal; # download time is more
3842                                             # important than upload
3843                                             # time
3844                 return $aslocal;
3845             } elsif ($url !~ /\.gz(?!\n)\Z/) {
3846                 my $gzurl = "$url.gz";
3847                 $CPAN::Frontend->myprint("Fetching with LWP:
3848   $gzurl
3849 ");
3850                 $res = $Ua->mirror($gzurl, "$aslocal.gz");
3851                 if ($res->is_success) {
3852                     if (eval {CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)}) {
3853                         $ThesiteURL = $ro_url;
3854                         return $aslocal;
3855                     }
3856                 }
3857             } else {
3858                 $CPAN::Frontend->myprint(sprintf(
3859                                                  "LWP failed with code[%s] message[%s]\n",
3860                                                  $res->code,
3861                                                  $res->message,
3862                                                 ));
3863                 # Alan Burlison informed me that in firewall environments
3864                 # Net::FTP can still succeed where LWP fails. So we do not
3865                 # skip Net::FTP anymore when LWP is available.
3866             }
3867         } else {
3868             $CPAN::Frontend->mywarn("  LWP not available\n");
3869         }
3870         return if $CPAN::Signal;
3871         if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3872             # that's the nice and easy way thanks to Graham
3873             $self->debug("recognized ftp") if $CPAN::DEBUG;
3874             my($host,$dir,$getfile) = ($1,$2,$3);
3875             if ($CPAN::META->has_usable('Net::FTP')) {
3876                 $dir =~ s|/+|/|g;
3877                 $CPAN::Frontend->myprint("Fetching with Net::FTP:
3878   $url
3879 ");
3880                 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
3881                              "aslocal[$aslocal]") if $CPAN::DEBUG;
3882                 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
3883                     $ThesiteURL = $ro_url;
3884                     return $aslocal;
3885                 }
3886                 if ($aslocal !~ /\.gz(?!\n)\Z/) {
3887                     my $gz = "$aslocal.gz";
3888                     $CPAN::Frontend->myprint("Fetching with Net::FTP
3889   $url.gz
3890 ");
3891                     if (CPAN::FTP->ftp_get($host,
3892                                            $dir,
3893                                            "$getfile.gz",
3894                                            $gz) &&
3895                         eval{CPAN::Tarzip->new($gz)->gunzip($aslocal)}
3896                        ){
3897                         $ThesiteURL = $ro_url;
3898                         return $aslocal;
3899                     }
3900                 }
3901                 # next HOSTEASY;
3902             } else {
3903                 CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG;
3904             }
3905         }
3906         if (
3907             UNIVERSAL::can($ro_url,"text")
3908             and
3909             $ro_url->{FROM} eq "USER"
3910            ){
3911             ##address #17973: default URLs should not try to override
3912             ##user-defined URLs just because LWP is not available
3913             my $ret = $self->hosthard([$ro_url],$file,$aslocal,$stats);
3914             return $ret if $ret;
3915         }
3916         return if $CPAN::Signal;
3917     }
3918 }
3919
3920 # package CPAN::FTP;
3921 sub hosthard {
3922   my($self,$host_seq,$file,$aslocal,$stats) = @_;
3923
3924   # Came back if Net::FTP couldn't establish connection (or
3925   # failed otherwise) Maybe they are behind a firewall, but they
3926   # gave us a socksified (or other) ftp program...
3927
3928   my($ro_url);
3929   my($devnull) = $CPAN::Config->{devnull} || "";
3930   # < /dev/null ";
3931   my($aslocal_dir) = File::Basename::dirname($aslocal);
3932   File::Path::mkpath($aslocal_dir);
3933   HOSTHARD: for $ro_url (@$host_seq) {
3934         $self->_set_attempt($stats,"hard",$ro_url);
3935         my $url = "$ro_url$file";
3936         my($proto,$host,$dir,$getfile);
3937
3938         # Courtesy Mark Conty mark_conty@cargill.com change from
3939         # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3940         # to
3941         if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
3942           # proto not yet used
3943           ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
3944         } else {
3945           next HOSTHARD; # who said, we could ftp anything except ftp?
3946         }
3947         next HOSTHARD if $proto eq "file"; # file URLs would have had
3948                                            # success above. Likely a bogus URL
3949
3950         $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
3951
3952         # Try the most capable first and leave ncftp* for last as it only
3953         # does FTP.
3954       DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
3955           my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
3956           next unless defined $funkyftp;
3957           next if $funkyftp =~ /^\s*$/;
3958
3959           my($asl_ungz, $asl_gz);
3960           ($asl_ungz = $aslocal) =~ s/\.gz//;
3961           $asl_gz = "$asl_ungz.gz";
3962
3963           my($src_switch) = "";
3964           my($chdir) = "";
3965           my($stdout_redir) = " > $asl_ungz";
3966           if ($f eq "lynx"){
3967             $src_switch = " -source";
3968           } elsif ($f eq "ncftp"){
3969             $src_switch = " -c";
3970           } elsif ($f eq "wget"){
3971             $src_switch = " -O $asl_ungz";
3972             $stdout_redir = "";
3973           } elsif ($f eq 'curl'){
3974             $src_switch = ' -L -f -s -S --netrc-optional';
3975           }
3976
3977           if ($f eq "ncftpget"){
3978             $chdir = "cd $aslocal_dir && ";
3979             $stdout_redir = "";
3980           }
3981           $CPAN::Frontend->myprint(
3982                                    qq[
3983 Trying with "$funkyftp$src_switch" to get
3984     $url
3985 ]);
3986           my($system) =
3987               "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
3988           $self->debug("system[$system]") if $CPAN::DEBUG;
3989           my($wstatus) = system($system);
3990           if ($f eq "lynx") {
3991               # lynx returns 0 when it fails somewhere
3992               if (-s $asl_ungz) {
3993                   my $content = do { local *FH;
3994                                      open FH, $asl_ungz or die;
3995                                      local $/;
3996                                      <FH> };
3997                   if ($content =~ /^<.*(<title>[45]|Error [45])/si) {
3998                       $CPAN::Frontend->mywarn(qq{
3999 No success, the file that lynx has has downloaded looks like an error message:
4000 $content
4001 });
4002                       $CPAN::Frontend->mysleep(1);
4003                       next DLPRG;
4004                   }
4005               } else {
4006                   $CPAN::Frontend->myprint(qq{
4007 No success, the file that lynx has has downloaded is an empty file.
4008 });
4009                   next DLPRG;
4010               }
4011           }
4012           if ($wstatus == 0) {
4013             if (-s $aslocal) {
4014               # Looks good
4015             } elsif ($asl_ungz ne $aslocal) {
4016               # test gzip integrity
4017               if (eval{CPAN::Tarzip->new($asl_ungz)->gtest}) {
4018                   # e.g. foo.tar is gzipped --> foo.tar.gz
4019                   rename $asl_ungz, $aslocal;
4020               } else {
4021                   eval{CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz)};
4022               }
4023             }
4024             $ThesiteURL = $ro_url;
4025             return $aslocal;
4026           } elsif ($url !~ /\.gz(?!\n)\Z/) {
4027             unlink $asl_ungz if
4028                 -f $asl_ungz && -s _ == 0;
4029             my $gz = "$aslocal.gz";
4030             my $gzurl = "$url.gz";
4031             $CPAN::Frontend->myprint(
4032                                      qq[
4033 Trying with "$funkyftp$src_switch" to get
4034   $url.gz
4035 ]);
4036             my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
4037             $self->debug("system[$system]") if $CPAN::DEBUG;
4038             my($wstatus);
4039             if (($wstatus = system($system)) == 0
4040                 &&
4041                 -s $asl_gz
4042                ) {
4043               # test gzip integrity
4044                 my $ct = eval{CPAN::Tarzip->new($asl_gz)};
4045                 if ($ct && $ct->gtest) {
4046                     $ct->gunzip($aslocal);
4047                 } else {
4048                     # somebody uncompressed file for us?
4049                     rename $asl_ungz, $aslocal;
4050                 }
4051                 $ThesiteURL = $ro_url;
4052                 return $aslocal;
4053             } else {
4054               unlink $asl_gz if -f $asl_gz;
4055             }
4056           } else {
4057             my $estatus = $wstatus >> 8;
4058             my $size = -f $aslocal ?
4059                 ", left\n$aslocal with size ".-s _ :
4060                     "\nWarning: expected file [$aslocal] doesn't exist";
4061             $CPAN::Frontend->myprint(qq{
4062 System call "$system"
4063 returned status $estatus (wstat $wstatus)$size
4064 });
4065           }
4066           return if $CPAN::Signal;
4067         } # transfer programs
4068     } # host
4069 }
4070
4071 # package CPAN::FTP;
4072 sub hosthardest {
4073     my($self,$host_seq,$file,$aslocal,$stats) = @_;
4074
4075     my($ro_url);
4076     my($aslocal_dir) = File::Basename::dirname($aslocal);
4077     File::Path::mkpath($aslocal_dir);
4078     my $ftpbin = $CPAN::Config->{ftp};
4079     unless ($ftpbin && length $ftpbin && MM->maybe_command($ftpbin)) {
4080         $CPAN::Frontend->myprint("No external ftp command available\n\n");
4081         return;
4082     }
4083     $CPAN::Frontend->mywarn(qq{
4084 As a last ressort we now switch to the external ftp command '$ftpbin'
4085 to get '$aslocal'.
4086
4087 Doing so often leads to problems that are hard to diagnose.
4088
4089 If you're victim of such problems, please consider unsetting the ftp
4090 config variable with
4091
4092     o conf ftp ""
4093     o conf commit
4094
4095 });
4096     $CPAN::Frontend->mysleep(2);
4097   HOSTHARDEST: for $ro_url (@$host_seq) {
4098         $self->_set_attempt($stats,"hardest",$ro_url);
4099         my $url = "$ro_url$file";
4100         $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
4101         unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
4102             next;
4103         }
4104         my($host,$dir,$getfile) = ($1,$2,$3);
4105         my $timestamp = 0;
4106         my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
4107            $ctime,$blksize,$blocks) = stat($aslocal);
4108         $timestamp = $mtime ||= 0;
4109         my($netrc) = CPAN::FTP::netrc->new;
4110         my($netrcfile) = $netrc->netrc;
4111         my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
4112         my $targetfile = File::Basename::basename($aslocal);
4113         my(@dialog);
4114         push(
4115              @dialog,
4116              "lcd $aslocal_dir",
4117              "cd /",
4118              map("cd $_", split /\//, $dir), # RFC 1738
4119              "bin",
4120              "get $getfile $targetfile",
4121              "quit"
4122             );
4123         if (! $netrcfile) {
4124             CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
4125         } elsif ($netrc->hasdefault || $netrc->contains($host)) {
4126             CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
4127                                 $netrc->hasdefault,
4128                                 $netrc->contains($host))) if $CPAN::DEBUG;
4129             if ($netrc->protected) {
4130                 my $dialog = join "", map { "    $_\n" } @dialog;
4131                 my $netrc_explain;
4132                 if ($netrc->contains($host)) {
4133                     $netrc_explain = "Relying that your .netrc entry for '$host' ".
4134                         "manages the login";
4135                 } else {
4136                     $netrc_explain = "Relying that your default .netrc entry ".
4137                         "manages the login";
4138                 }
4139                 $CPAN::Frontend->myprint(qq{
4140   Trying with external ftp to get
4141     $url
4142   $netrc_explain
4143   Going to send the dialog
4144 $dialog
4145 }
4146                      );
4147                 $self->talk_ftp("$ftpbin$verbose $host",
4148                                 @dialog);
4149                 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4150                  $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
4151                 $mtime ||= 0;
4152                 if ($mtime > $timestamp) {
4153                     $CPAN::Frontend->myprint("GOT $aslocal\n");
4154                     $ThesiteURL = $ro_url;
4155                     return $aslocal;
4156                 } else {
4157                     $CPAN::Frontend->myprint("Hmm... Still failed!\n");
4158                 }
4159                 return if $CPAN::Signal;
4160             } else {
4161                 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
4162                                         qq{correctly protected.\n});
4163             }
4164         } else {
4165             $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
4166   nor does it have a default entry\n");
4167         }
4168
4169         # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
4170         # then and login manually to host, using e-mail as
4171         # password.
4172         $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
4173         unshift(
4174                 @dialog,
4175                 "open $host",
4176                 "user anonymous $Config::Config{'cf_email'}"
4177                );
4178         my $dialog = join "", map { "    $_\n" } @dialog;
4179         $CPAN::Frontend->myprint(qq{
4180   Trying with external ftp to get
4181     $url
4182   Going to send the dialog
4183 $dialog
4184 }
4185                      );
4186         $self->talk_ftp("$ftpbin$verbose -n", @dialog);
4187         ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4188          $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
4189         $mtime ||= 0;
4190         if ($mtime > $timestamp) {
4191             $CPAN::Frontend->myprint("GOT $aslocal\n");
4192             $ThesiteURL = $ro_url;
4193             return $aslocal;
4194         } else {
4195             $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
4196         }
4197         return if $CPAN::Signal;
4198         $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
4199         $CPAN::Frontend->mysleep(2);
4200     } # host
4201 }
4202
4203 # package CPAN::FTP;
4204 sub talk_ftp {
4205     my($self,$command,@dialog) = @_;
4206     my $fh = FileHandle->new;
4207     $fh->open("|$command") or die "Couldn't open ftp: $!";
4208     foreach (@dialog) { $fh->print("$_\n") }
4209     $fh->close;         # Wait for process to complete
4210     my $wstatus = $?;
4211     my $estatus = $wstatus >> 8;
4212     $CPAN::Frontend->myprint(qq{
4213 Subprocess "|$command"
4214   returned status $estatus (wstat $wstatus)
4215 }) if $wstatus;
4216 }
4217
4218 # find2perl needs modularization, too, all the following is stolen
4219 # from there
4220 # CPAN::FTP::ls
4221 sub ls {
4222     my($self,$name) = @_;
4223     my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
4224      $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
4225
4226     my($perms,%user,%group);
4227     my $pname = $name;
4228
4229     if ($blocks) {
4230         $blocks = int(($blocks + 1) / 2);
4231     }
4232     else {
4233         $blocks = int(($sizemm + 1023) / 1024);
4234     }
4235
4236     if    (-f _) { $perms = '-'; }
4237     elsif (-d _) { $perms = 'd'; }
4238     elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
4239     elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
4240     elsif (-p _) { $perms = 'p'; }
4241     elsif (-S _) { $perms = 's'; }
4242     else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
4243
4244     my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
4245     my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
4246     my $tmpmode = $mode;
4247     my $tmp = $rwx[$tmpmode & 7];
4248     $tmpmode >>= 3;
4249     $tmp = $rwx[$tmpmode & 7] . $tmp;
4250     $tmpmode >>= 3;
4251     $tmp = $rwx[$tmpmode & 7] . $tmp;
4252     substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
4253     substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
4254     substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
4255     $perms .= $tmp;
4256
4257     my $user = $user{$uid} || $uid;   # too lazy to implement lookup
4258     my $group = $group{$gid} || $gid;
4259
4260     my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
4261     my($timeyear);
4262     my($moname) = $moname[$mon];
4263     if (-M _ > 365.25 / 2) {
4264         $timeyear = $year + 1900;
4265     }
4266     else {
4267         $timeyear = sprintf("%02d:%02d", $hour, $min);
4268     }
4269
4270     sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
4271             $ino,
4272                  $blocks,
4273                       $perms,
4274                             $nlink,
4275                                 $user,
4276                                      $group,
4277                                           $sizemm,
4278                                               $moname,
4279                                                  $mday,
4280                                                      $timeyear,
4281                                                          $pname;
4282 }
4283
4284 package CPAN::FTP::netrc;
4285 use strict;
4286
4287 # package CPAN::FTP::netrc;
4288 sub new {
4289     my($class) = @_;
4290     my $home = CPAN::HandleConfig::home;
4291     my $file = File::Spec->catfile($home,".netrc");
4292
4293     my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4294        $atime,$mtime,$ctime,$blksize,$blocks)
4295         = stat($file);
4296     $mode ||= 0;
4297     my $protected = 0;
4298
4299     my($fh,@machines,$hasdefault);
4300     $hasdefault = 0;
4301     $fh = FileHandle->new or die "Could not create a filehandle";
4302
4303     if($fh->open($file)){
4304         $protected = ($mode & 077) == 0;
4305         local($/) = "";
4306       NETRC: while (<$fh>) {
4307             my(@tokens) = split " ", $_;
4308           TOKEN: while (@tokens) {
4309                 my($t) = shift @tokens;
4310                 if ($t eq "default"){
4311                     $hasdefault++;
4312                     last NETRC;
4313                 }
4314                 last TOKEN if $t eq "macdef";
4315                 if ($t eq "machine") {
4316                     push @machines, shift @tokens;
4317                 }
4318             }
4319         }
4320     } else {
4321         $file = $hasdefault = $protected = "";
4322     }
4323
4324     bless {
4325            'mach' => [@machines],
4326            'netrc' => $file,
4327            'hasdefault' => $hasdefault,
4328            'protected' => $protected,
4329           }, $class;
4330 }
4331
4332 # CPAN::FTP::netrc::hasdefault;
4333 sub hasdefault { shift->{'hasdefault'} }
4334 sub netrc      { shift->{'netrc'}      }
4335 sub protected  { shift->{'protected'}  }
4336 sub contains {
4337     my($self,$mach) = @_;
4338     for ( @{$self->{'mach'}} ) {
4339         return 1 if $_ eq $mach;
4340     }
4341     return 0;
4342 }
4343
4344 package CPAN::Complete;
4345 use strict;
4346
4347 sub gnu_cpl {
4348     my($text, $line, $start, $end) = @_;
4349     my(@perlret) = cpl($text, $line, $start);
4350     # find longest common match. Can anybody show me how to peruse
4351     # T::R::Gnu to have this done automatically? Seems expensive.
4352     return () unless @perlret;
4353     my($newtext) = $text;
4354     for (my $i = length($text)+1;;$i++) {
4355         last unless length($perlret[0]) && length($perlret[0]) >= $i;
4356         my $try = substr($perlret[0],0,$i);
4357         my @tries = grep {substr($_,0,$i) eq $try} @perlret;
4358         # warn "try[$try]tries[@tries]";
4359         if (@tries == @perlret) {
4360             $newtext = $try;
4361         } else {
4362             last;
4363         }
4364     }
4365     ($newtext,@perlret);
4366 }
4367
4368 #-> sub CPAN::Complete::cpl ;
4369 sub cpl {
4370     my($word,$line,$pos) = @_;
4371     $word ||= "";
4372     $line ||= "";
4373     $pos ||= 0;
4374     CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4375     $line =~ s/^\s*//;
4376     if ($line =~ s/^((?:notest|f?force)\s*)//) {
4377         $pos -= length($1);
4378     }
4379     my @return;
4380     if ($pos == 0) {
4381         @return = grep /^$word/, @CPAN::Complete::COMMANDS;
4382     } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
4383         @return = ();
4384     } elsif ($line =~ /^(a|ls)\s/) {
4385         @return = cplx('CPAN::Author',uc($word));
4386     } elsif ($line =~ /^b\s/) {
4387         CPAN::Shell->local_bundles;
4388         @return = cplx('CPAN::Bundle',$word);
4389     } elsif ($line =~ /^d\s/) {
4390         @return = cplx('CPAN::Distribution',$word);
4391     } elsif ($line =~ m/^(
4392                           [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
4393                          )\s/x ) {
4394         if ($word =~ /^Bundle::/) {
4395             CPAN::Shell->local_bundles;
4396         }
4397         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
4398     } elsif ($line =~ /^i\s/) {
4399         @return = cpl_any($word);
4400     } elsif ($line =~ /^reload\s/) {
4401         @return = cpl_reload($word,$line,$pos);
4402     } elsif ($line =~ /^o\s/) {
4403         @return = cpl_option($word,$line,$pos);
4404     } elsif ($line =~ m/^\S+\s/ ) {
4405         # fallback for future commands and what we have forgotten above
4406         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
4407     } else {
4408         @return = ();
4409     }
4410     return @return;
4411 }
4412
4413 #-> sub CPAN::Complete::cplx ;
4414 sub cplx {
4415     my($class, $word) = @_;
4416     if (CPAN::_sqlite_running) {
4417         $CPAN::SQLite->search($class, "^\Q$word\E");
4418     }
4419     sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
4420 }
4421
4422 #-> sub CPAN::Complete::cpl_any ;
4423 sub cpl_any {
4424     my($word) = shift;
4425     return (
4426             cplx('CPAN::Author',$word),
4427             cplx('CPAN::Bundle',$word),
4428             cplx('CPAN::Distribution',$word),
4429             cplx('CPAN::Module',$word),
4430            );
4431 }
4432
4433 #-> sub CPAN::Complete::cpl_reload ;
4434 sub cpl_reload {
4435     my($word,$line,$pos) = @_;
4436     $word ||= "";
4437     my(@words) = split " ", $line;
4438     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4439     my(@ok) = qw(cpan index);
4440     return @ok if @words == 1;
4441     return grep /^\Q$word\E/, @ok if @words == 2 && $word;
4442 }
4443
4444 #-> sub CPAN::Complete::cpl_option ;
4445 sub cpl_option {
4446     my($word,$line,$pos) = @_;
4447     $word ||= "";
4448     my(@words) = split " ", $line;
4449     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4450     my(@ok) = qw(conf debug);
4451     return @ok if @words == 1;
4452     return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
4453     if (0) {
4454     } elsif ($words[1] eq 'index') {
4455         return ();
4456     } elsif ($words[1] eq 'conf') {
4457         return CPAN::HandleConfig::cpl(@_);
4458     } elsif ($words[1] eq 'debug') {
4459         return sort grep /^\Q$word\E/i,
4460             sort keys %CPAN::DEBUG, 'all';
4461     }
4462 }
4463
4464 package CPAN::Index;
4465 use strict;
4466
4467 #-> sub CPAN::Index::force_reload ;
4468 sub force_reload {
4469     my($class) = @_;
4470     $CPAN::Index::LAST_TIME = 0;
4471     $class->reload(1);
4472 }
4473
4474 #-> sub CPAN::Index::reload ;
4475 sub reload {
4476     my($self,$force) = @_;
4477     my $time = time;
4478
4479     # XXX check if a newer one is available. (We currently read it
4480     # from time to time)
4481     for ($CPAN::Config->{index_expire}) {
4482         $_ = 0.001 unless $_ && $_ > 0.001;
4483     }
4484     unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
4485         # debug here when CPAN doesn't seem to read the Metadata
4486         require Carp;
4487         Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
4488     }
4489     unless ($CPAN::META->{PROTOCOL}) {
4490         $self->read_metadata_cache;
4491         $CPAN::META->{PROTOCOL} ||= "1.0";
4492     }
4493     if ( $CPAN::META->{PROTOCOL} < PROTOCOL  ) {
4494         # warn "Setting last_time to 0";
4495         $LAST_TIME = 0; # No warning necessary
4496     }
4497     if ($LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
4498         and ! $force){
4499         # called too often
4500         # CPAN->debug("LAST_TIME[$LAST_TIME]index_expire[$CPAN::Config->{index_expire}]time[$time]");
4501     } elsif (0) {
4502         # IFF we are developing, it helps to wipe out the memory
4503         # between reloads, otherwise it is not what a user expects.
4504         undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
4505         $CPAN::META = CPAN->new;
4506     } else {
4507         my($debug,$t2);
4508         local $LAST_TIME = $time;
4509         local $CPAN::META->{PROTOCOL} = PROTOCOL;
4510
4511         my $needshort = $^O eq "dos";
4512
4513         $self->rd_authindex($self
4514                           ->reload_x(
4515                                      "authors/01mailrc.txt.gz",
4516                                      $needshort ?
4517                                      File::Spec->catfile('authors', '01mailrc.gz') :
4518                                      File::Spec->catfile('authors', '01mailrc.txt.gz'),
4519                                      $force));
4520         $t2 = time;
4521         $debug = "timing reading 01[".($t2 - $time)."]";
4522         $time = $t2;
4523         return if $CPAN::Signal; # this is sometimes lengthy
4524         $self->rd_modpacks($self
4525                          ->reload_x(
4526                                     "modules/02packages.details.txt.gz",
4527                                     $needshort ?
4528                                     File::Spec->catfile('modules', '02packag.gz') :
4529                                     File::Spec->catfile('modules', '02packages.details.txt.gz'),
4530                                     $force));
4531         $t2 = time;
4532         $debug .= "02[".($t2 - $time)."]";
4533         $time = $t2;
4534         return if $CPAN::Signal; # this is sometimes lengthy
4535         $self->rd_modlist($self
4536                         ->reload_x(
4537                                    "modules/03modlist.data.gz",
4538                                    $needshort ?
4539                                    File::Spec->catfile('modules', '03mlist.gz') :
4540                                    File::Spec->catfile('modules', '03modlist.data.gz'),
4541                                    $force));
4542         $self->write_metadata_cache;
4543         $t2 = time;
4544         $debug .= "03[".($t2 - $time)."]";
4545         $time = $t2;
4546         CPAN->debug($debug) if $CPAN::DEBUG;
4547     }
4548     if ($CPAN::Config->{build_dir_reuse}) {
4549         $self->reanimate_build_dir;
4550     }
4551     if (CPAN::_sqlite_running) {
4552         $CPAN::SQLite->reload(time => $time, force => $force)
4553             if not $LAST_TIME;
4554     }
4555     $LAST_TIME = $time;
4556     $CPAN::META->{PROTOCOL} = PROTOCOL;
4557 }
4558
4559 #-> sub CPAN::Index::reanimate_build_dir ;
4560 sub reanimate_build_dir {
4561     my($self) = @_;
4562     unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module}||"YAML")) {
4563         return;
4564     }
4565     return if $HAVE_REANIMATED++;
4566     my $d = $CPAN::Config->{build_dir};
4567     my $dh = DirHandle->new;
4568     opendir $dh, $d or return; # does not exist
4569     my $dirent;
4570     my $i = 0;
4571     my $painted = 0;
4572     my $restored = 0;
4573     $CPAN::Frontend->myprint("Going to read $CPAN::Config->{build_dir}/\n");
4574     my @candidates = map { $_->[0] }
4575         sort { $b->[1] <=> $a->[1] }
4576             map { [ $_, -M File::Spec->catfile($d,$_) ] }
4577                 grep {/\.yml$/} readdir $dh;
4578   DISTRO: for $dirent (@candidates) {
4579         my $y = eval {CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))};
4580         die $@ if $@;
4581         my $c = $y->[0];
4582         if ($c && CPAN->_perl_fingerprint($c->{perl})) {
4583             my $key = $c->{distribution}{ID};
4584             for my $k (keys %{$c->{distribution}}) {
4585                 if ($c->{distribution}{$k}
4586                     && ref $c->{distribution}{$k}
4587                     && UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) {
4588                     $c->{distribution}{$k}{COMMANDID} = $i - @candidates;
4589                 }
4590             }
4591
4592             #we tried to restore only if element already
4593             #exists; but then we do not work with metadata
4594             #turned off.
4595             my $do
4596                 = $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key}
4597                     = $c->{distribution};
4598             delete $do->{badtestcnt};
4599             # $DB::single = 1;
4600             if ($do->{make_test}
4601                 && $do->{build_dir}
4602                 && !$do->{make_test}->failed
4603                 && (
4604                     !$do->{install}
4605                     ||
4606                     $do->{install}->failed
4607                    )
4608                ) {
4609                 $CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME});
4610             }
4611             $restored++;
4612         }
4613         $i++;
4614         while (($painted/76) < ($i/@candidates)) {
4615             $CPAN::Frontend->myprint(".");
4616             $painted++;
4617         }
4618     }
4619     $CPAN::Frontend->myprint(sprintf(
4620                                      "DONE\nFound %s old builds, restored the state of %s\n",
4621                                      @candidates ? sprintf("%d",scalar @candidates) : "no",
4622                                      $restored || "none",
4623                                     ));
4624 }
4625
4626
4627 #-> sub CPAN::Index::reload_x ;
4628 sub reload_x {
4629     my($cl,$wanted,$localname,$force) = @_;
4630     $force |= 2; # means we're dealing with an index here
4631     CPAN::HandleConfig->load; # we should guarantee loading wherever
4632                               # we rely on Config XXX
4633     $localname ||= $wanted;
4634     my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
4635                                          $localname);
4636     if (
4637         -f $abs_wanted &&
4638         -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
4639         !($force & 1)
4640        ) {
4641         my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
4642         $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
4643                    qq{day$s. I\'ll use that.});
4644         return $abs_wanted;
4645     } else {
4646         $force |= 1; # means we're quite serious about it.
4647     }
4648     return CPAN::FTP->localize($wanted,$abs_wanted,$force);
4649 }
4650
4651 #-> sub CPAN::Index::rd_authindex ;
4652 sub rd_authindex {
4653     my($cl, $index_target) = @_;
4654     return unless defined $index_target;
4655     return if CPAN::_sqlite_running;
4656     my @lines;
4657     $CPAN::Frontend->myprint("Going to read $index_target\n");
4658     local(*FH);
4659     tie *FH, 'CPAN::Tarzip', $index_target;
4660     local($/) = "\n";
4661     local($_);
4662     push @lines, split /\012/ while <FH>;
4663     my $i = 0;
4664     my $painted = 0;
4665     foreach (@lines) {
4666         my($userid,$fullname,$email) =
4667             m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/;
4668         $fullname ||= $email;
4669         if ($userid && $fullname && $email){
4670             my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
4671             $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
4672         } else {
4673             CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG;
4674         }
4675         $i++;
4676         while (($painted/76) < ($i/@lines)) {
4677             $CPAN::Frontend->myprint(".");
4678             $painted++;
4679         }
4680         return if $CPAN::Signal;
4681     }
4682     $CPAN::Frontend->myprint("DONE\n");
4683 }
4684
4685 sub userid {
4686   my($self,$dist) = @_;
4687   $dist = $self->{'id'} unless defined $dist;
4688   my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
4689   $ret;
4690 }
4691
4692 #-> sub CPAN::Index::rd_modpacks ;
4693 sub rd_modpacks {
4694     my($self, $index_target) = @_;
4695     return unless defined $index_target;
4696     return if CPAN::_sqlite_running;
4697     $CPAN::Frontend->myprint("Going to read $index_target\n");
4698     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
4699     local $_;
4700     CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
4701     my $slurp = "";
4702     my $chunk;
4703     while (my $bytes = $fh->READ(\$chunk,8192)) {
4704         $slurp.=$chunk;
4705     }
4706     my @lines = split /\012/, $slurp;
4707     CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
4708     undef $fh;
4709     # read header
4710     my($line_count,$last_updated);
4711     while (@lines) {
4712         my $shift = shift(@lines);
4713         last if $shift =~ /^\s*$/;
4714         $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
4715         $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
4716     }
4717     CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
4718     if (not defined $line_count) {
4719
4720         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
4721 Please check the validity of the index file by comparing it to more
4722 than one CPAN mirror. I'll continue but problems seem likely to
4723 happen.\a
4724 });
4725
4726         $CPAN::Frontend->mysleep(5);
4727     } elsif ($line_count != scalar @lines) {
4728
4729         $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
4730 contains a Line-Count header of %d but I see %d lines there. Please
4731 check the validity of the index file by comparing it to more than one
4732 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
4733 $index_target, $line_count, scalar(@lines));
4734
4735     }
4736     if (not defined $last_updated) {
4737
4738         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
4739 Please check the validity of the index file by comparing it to more
4740 than one CPAN mirror. I'll continue but problems seem likely to
4741 happen.\a
4742 });
4743
4744         $CPAN::Frontend->mysleep(5);
4745     } else {
4746
4747         $CPAN::Frontend
4748             ->myprint(sprintf qq{  Database was generated on %s\n},
4749                       $last_updated);
4750         $DATE_OF_02 = $last_updated;
4751
4752         my $age = time;
4753         if ($CPAN::META->has_inst('HTTP::Date')) {
4754             require HTTP::Date;
4755             $age -= HTTP::Date::str2time($last_updated);
4756         } else {
4757             $CPAN::Frontend->mywarn("  HTTP::Date not available\n");
4758             require Time::Local;
4759             my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
4760             $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
4761             $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
4762         }
4763         $age /= 3600*24;
4764         if ($age > 30) {
4765
4766             $CPAN::Frontend
4767                 ->mywarn(sprintf
4768                          qq{Warning: This index file is %d days old.
4769   Please check the host you chose as your CPAN mirror for staleness.
4770   I'll continue but problems seem likely to happen.\a\n},
4771                          $age);
4772
4773         } elsif ($age < -1) {
4774
4775             $CPAN::Frontend
4776                 ->mywarn(sprintf
4777                          qq{Warning: Your system date is %d days behind this index file!
4778   System time:          %s
4779   Timestamp index file: %s
4780   Please fix your system time, problems with the make command expected.\n},
4781                          -$age,
4782                          scalar gmtime,
4783                          $DATE_OF_02,
4784                         );
4785
4786         }
4787     }
4788
4789
4790     # A necessity since we have metadata_cache: delete what isn't
4791     # there anymore
4792     my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
4793     CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
4794     my(%exists);
4795     my $i = 0;
4796     my $painted = 0;
4797     foreach (@lines) {
4798         # before 1.56 we split into 3 and discarded the rest. From
4799         # 1.57 we assign remaining text to $comment thus allowing to
4800         # influence isa_perl
4801         my($mod,$version,$dist,$comment) = split " ", $_, 4;
4802         my($bundle,$id,$userid);
4803
4804         if ($mod eq 'CPAN' &&
4805             ! (
4806                CPAN::Queue->exists('Bundle::CPAN') ||
4807                CPAN::Queue->exists('CPAN')
4808               )
4809            ) {
4810             local($^W)= 0;
4811             if ($version > $CPAN::VERSION){
4812                 $CPAN::Frontend->mywarn(qq{
4813   New CPAN.pm version (v$version) available.
4814   [Currently running version is v$CPAN::VERSION]
4815   You might want to try
4816     install CPAN
4817     reload cpan
4818   to both upgrade CPAN.pm and run the new version without leaving
4819   the current session.
4820
4821 }); #});
4822                 $CPAN::Frontend->mysleep(2);
4823                 $CPAN::Frontend->myprint(qq{\n});
4824             }
4825             last if $CPAN::Signal;
4826         } elsif ($mod =~ /^Bundle::(.*)/) {
4827             $bundle = $1;
4828         }
4829
4830         if ($bundle){
4831             $id =  $CPAN::META->instance('CPAN::Bundle',$mod);
4832             # Let's make it a module too, because bundles have so much
4833             # in common with modules.
4834
4835             # Changed in 1.57_63: seems like memory bloat now without
4836             # any value, so commented out
4837
4838             # $CPAN::META->instance('CPAN::Module',$mod);
4839
4840         } else {
4841
4842             # instantiate a module object
4843             $id = $CPAN::META->instance('CPAN::Module',$mod);
4844
4845         }
4846
4847         # Although CPAN prohibits same name with different version the
4848         # indexer may have changed the version for the same distro
4849         # since the last time ("Force Reindexing" feature)
4850         if ($id->cpan_file ne $dist
4851             ||
4852             $id->cpan_version ne $version
4853            ){
4854             $userid = $id->userid || $self->userid($dist);
4855             $id->set(
4856                      'CPAN_USERID' => $userid,
4857                      'CPAN_VERSION' => $version,
4858                      'CPAN_FILE' => $dist,
4859                     );
4860         }
4861
4862         # instantiate a distribution object
4863         if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
4864           # we do not need CONTAINSMODS unless we do something with
4865           # this dist, so we better produce it on demand.
4866
4867           ## my $obj = $CPAN::META->instance(
4868           ##                              'CPAN::Distribution' => $dist
4869           ##                             );
4870           ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
4871         } else {
4872           $CPAN::META->instance(
4873                                 'CPAN::Distribution' => $dist
4874                                )->set(
4875                                       'CPAN_USERID' => $userid,
4876                                       'CPAN_COMMENT' => $comment,
4877                                      );
4878         }
4879         if ($secondtime) {
4880             for my $name ($mod,$dist) {
4881                 # $self->debug("exists name[$name]") if $CPAN::DEBUG;
4882                 $exists{$name} = undef;
4883             }
4884         }
4885         $i++;
4886         while (($painted/76) < ($i/@lines)) {
4887             $CPAN::Frontend->myprint(".");
4888             $painted++;
4889         }
4890         return if $CPAN::Signal;
4891     }
4892     $CPAN::Frontend->myprint("DONE\n");
4893     if ($secondtime) {
4894         for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
4895             for my $o ($CPAN::META->all_objects($class)) {
4896                 next if exists $exists{$o->{ID}};
4897                 $CPAN::META->delete($class,$o->{ID});
4898                 # CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
4899                 #     if $CPAN::DEBUG;
4900             }
4901         }
4902     }
4903 }
4904
4905 #-> sub CPAN::Index::rd_modlist ;
4906 sub rd_modlist {
4907     my($cl,$index_target) = @_;
4908     return unless defined $index_target;
4909     return if CPAN::_sqlite_running;
4910     $CPAN::Frontend->myprint("Going to read $index_target\n");
4911     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
4912     local $_;
4913     my $slurp = "";
4914     my $chunk;
4915     while (my $bytes = $fh->READ(\$chunk,8192)) {
4916         $slurp.=$chunk;
4917     }
4918     my @eval2 = split /\012/, $slurp;
4919
4920     while (@eval2) {
4921         my $shift = shift(@eval2);
4922         if ($shift =~ /^Date:\s+(.*)/){
4923             if ($DATE_OF_03 eq $1){
4924                 $CPAN::Frontend->myprint("Unchanged.\n");
4925                 return;
4926             }
4927             ($DATE_OF_03) = $1;
4928         }
4929         last if $shift =~ /^\s*$/;
4930     }
4931     push @eval2, q{CPAN::Modulelist->data;};
4932     local($^W) = 0;
4933     my($comp) = Safe->new("CPAN::Safe1");
4934     my($eval2) = join("\n", @eval2);
4935     CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG;
4936     my $ret = $comp->reval($eval2);
4937     Carp::confess($@) if $@;
4938     return if $CPAN::Signal;
4939     my $i = 0;
4940     my $until = keys(%$ret);
4941     my $painted = 0;
4942     CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
4943     for (keys %$ret) {
4944         my $obj = $CPAN::META->instance("CPAN::Module",$_);
4945         delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
4946         $obj->set(%{$ret->{$_}});
4947         $i++;
4948         while (($painted/76) < ($i/$until)) {
4949             $CPAN::Frontend->myprint(".");
4950             $painted++;
4951         }
4952         return if $CPAN::Signal;
4953     }
4954     $CPAN::Frontend->myprint("DONE\n");
4955 }
4956
4957 #-> sub CPAN::Index::write_metadata_cache ;
4958 sub write_metadata_cache {
4959     my($self) = @_;
4960     return unless $CPAN::Config->{'cache_metadata'};
4961     return if CPAN::_sqlite_running;
4962     return unless $CPAN::META->has_usable("Storable");
4963     my $cache;
4964     foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
4965                       CPAN::Distribution)) {
4966         $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
4967     }
4968     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
4969     $cache->{last_time} = $LAST_TIME;
4970     $cache->{DATE_OF_02} = $DATE_OF_02;
4971     $cache->{PROTOCOL} = PROTOCOL;
4972     $CPAN::Frontend->myprint("Going to write $metadata_file\n");
4973     eval { Storable::nstore($cache, $metadata_file) };
4974     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
4975 }
4976
4977 #-> sub CPAN::Index::read_metadata_cache ;
4978 sub read_metadata_cache {
4979     my($self) = @_;
4980     return unless $CPAN::Config->{'cache_metadata'};
4981     return if CPAN::_sqlite_running;
4982     return unless $CPAN::META->has_usable("Storable");
4983     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
4984     return unless -r $metadata_file and -f $metadata_file;
4985     $CPAN::Frontend->myprint("Going to read $metadata_file\n");
4986     my $cache;
4987     eval { $cache = Storable::retrieve($metadata_file) };
4988     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
4989     if (!$cache || !UNIVERSAL::isa($cache, 'HASH')){
4990         $LAST_TIME = 0;
4991         return;
4992     }
4993     if (exists $cache->{PROTOCOL}) {
4994         if (PROTOCOL > $cache->{PROTOCOL}) {
4995             $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
4996                                             "with protocol v%s, requiring v%s\n",
4997                                             $cache->{PROTOCOL},
4998                                             PROTOCOL)
4999                                    );
5000             return;
5001         }
5002     } else {
5003         $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
5004                                 "with protocol v1.0\n");
5005         return;
5006     }
5007     my $clcnt = 0;
5008     my $idcnt = 0;
5009     while(my($class,$v) = each %$cache) {
5010         next unless $class =~ /^CPAN::/;
5011         $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
5012         while (my($id,$ro) = each %$v) {
5013             $CPAN::META->{readwrite}{$class}{$id} ||=
5014                 $class->new(ID=>$id, RO=>$ro);
5015             $idcnt++;
5016         }
5017         $clcnt++;
5018     }
5019     unless ($clcnt) { # sanity check
5020         $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
5021         return;
5022     }
5023     if ($idcnt < 1000) {
5024         $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
5025                                  "in $metadata_file\n");
5026         return;
5027     }
5028     $CPAN::META->{PROTOCOL} ||=
5029         $cache->{PROTOCOL}; # reading does not up or downgrade, but it
5030                             # does initialize to some protocol
5031     $LAST_TIME = $cache->{last_time};
5032     $DATE_OF_02 = $cache->{DATE_OF_02};
5033     $CPAN::Frontend->myprint("  Database was generated on $DATE_OF_02\n")
5034         if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
5035     return;
5036 }
5037
5038 package CPAN::InfoObj;
5039 use strict;
5040
5041 sub ro {
5042     my $self = shift;
5043     exists $self->{RO} and return $self->{RO};
5044 }
5045
5046 #-> sub CPAN::InfoObj::cpan_userid
5047 sub cpan_userid {
5048     my $self = shift;
5049     my $ro = $self->ro;
5050     if ($ro) {
5051         return $ro->{CPAN_USERID} || "N/A";
5052     } else {
5053         $self->debug("ID[$self->{ID}]");
5054         # N/A for bundles found locally
5055         return "N/A";
5056     }
5057 }
5058
5059 sub id { shift->{ID}; }
5060
5061 #-> sub CPAN::InfoObj::new ;
5062 sub new {
5063     my $this = bless {}, shift;
5064     %$this = @_;
5065     $this
5066 }
5067
5068 # The set method may only be used by code that reads index data or
5069 # otherwise "objective" data from the outside world. All session
5070 # related material may do anything else with instance variables but
5071 # must not touch the hash under the RO attribute. The reason is that
5072 # the RO hash gets written to Metadata file and is thus persistent.
5073
5074 #-> sub CPAN::InfoObj::safe_chdir ;
5075 sub safe_chdir {
5076   my($self,$todir) = @_;
5077   # we die if we cannot chdir and we are debuggable
5078   Carp::confess("safe_chdir called without todir argument")
5079         unless defined $todir and length $todir;
5080   if (chdir $todir) {
5081     $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
5082         if $CPAN::DEBUG;
5083   } else {
5084     if (-e $todir) {
5085         unless (-x $todir) {
5086             unless (chmod 0755, $todir) {
5087                 my $cwd = CPAN::anycwd();
5088                 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
5089                                         "permission to change the permission; cannot ".
5090                                         "chdir to '$todir'\n");
5091                 $CPAN::Frontend->mysleep(5);
5092                 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
5093                                        qq{to todir[$todir]: $!});
5094             }
5095         }
5096     } else {
5097         $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n");
5098     }
5099     if (chdir $todir) {
5100       $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
5101           if $CPAN::DEBUG;
5102     } else {
5103       my $cwd = CPAN::anycwd();
5104       $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
5105                              qq{to todir[$todir] (a chmod has been issued): $!});
5106     }
5107   }
5108 }
5109
5110 #-> sub CPAN::InfoObj::set ;
5111 sub set {
5112     my($self,%att) = @_;
5113     my $class = ref $self;
5114
5115     # This must be ||=, not ||, because only if we write an empty
5116     # reference, only then the set method will write into the readonly
5117     # area. But for Distributions that spring into existence, maybe
5118     # because of a typo, we do not like it that they are written into
5119     # the readonly area and made permanent (at least for a while) and
5120     # that is why we do not "allow" other places to call ->set.
5121     unless ($self->id) {
5122         CPAN->debug("Bug? Empty ID, rejecting");
5123         return;
5124     }
5125     my $ro = $self->{RO} =
5126         $CPAN::META->{readonly}{$class}{$self->id} ||= {};
5127
5128     while (my($k,$v) = each %att) {
5129         $ro->{$k} = $v;
5130     }
5131 }
5132
5133 #-> sub CPAN::InfoObj::as_glimpse ;
5134 sub as_glimpse {
5135     my($self) = @_;
5136     my(@m);
5137     my $class = ref($self);
5138     $class =~ s/^CPAN:://;
5139     my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID};
5140     push @m, sprintf "%-15s %s\n", $class, $id;
5141     join "", @m;
5142 }
5143
5144 #-> sub CPAN::InfoObj::as_string ;
5145 sub as_string {
5146     my($self) = @_;
5147     my(@m);
5148     my $class = ref($self);
5149     $class =~ s/^CPAN:://;
5150     push @m, $class, " id = $self->{ID}\n";
5151     my $ro;
5152     unless ($ro = $self->ro) {
5153         if (substr($self->{ID},-1,1) eq ".") { # directory
5154             $ro = +{};
5155         } else {
5156             $CPAN::Frontend->mydie("Unknown object $self->{ID}");
5157         }
5158     }
5159     for (sort keys %$ro) {
5160         # next if m/^(ID|RO)$/;
5161         my $extra = "";
5162         if ($_ eq "CPAN_USERID") {
5163             $extra .= " (";
5164             $extra .= $self->fullname;
5165             my $email; # old perls!
5166             if ($email = $CPAN::META->instance("CPAN::Author",
5167                                                $self->cpan_userid
5168                                               )->email) {
5169                 $extra .= " <$email>";
5170             } else {
5171                 $extra .= " <no email>";
5172             }
5173             $extra .= ")";
5174         } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
5175             push @m, sprintf "    %-12s %s\n", $_, $self->fullname;
5176             next;
5177         }
5178         next unless defined $ro->{$_};
5179         push @m, sprintf "    %-12s %s%s\n", $_, $ro->{$_}, $extra;
5180     }
5181   KEY: for (sort keys %$self) {
5182         next if m/^(ID|RO)$/;
5183         unless (defined $self->{$_}) {
5184             delete $self->{$_};
5185             next KEY;
5186         }
5187         if (ref($self->{$_}) eq "ARRAY") {
5188           push @m, sprintf "    %-12s %s\n", $_, "@{$self->{$_}}";
5189         } elsif (ref($self->{$_}) eq "HASH") {
5190             my $value;
5191             if (/^CONTAINSMODS$/) {
5192                 $value = join(" ",sort keys %{$self->{$_}});
5193             } elsif (/^prereq_pm$/) {
5194                 my @value;
5195                 my $v = $self->{$_};
5196                 for my $x (sort keys %$v) {
5197                     my @svalue;
5198                     for my $y (sort keys %{$v->{$x}}) {
5199                         push @svalue, "$y=>$v->{$x}{$y}";
5200                     }
5201                     push @value, "$x\:" . join ",", @svalue if @svalue;
5202                 }
5203                 $value = join ";", @value;
5204             } else {
5205                 $value = $self->{$_};
5206             }
5207           push @m, sprintf(
5208                            "    %-12s %s\n",
5209                            $_,
5210                            $value,
5211                           );
5212         } else {
5213           push @m, sprintf "    %-12s %s\n", $_, $self->{$_};
5214         }
5215     }
5216     join "", @m, "\n";
5217 }
5218
5219 #-> sub CPAN::InfoObj::fullname ;
5220 sub fullname {
5221     my($self) = @_;
5222     $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
5223 }
5224
5225 #-> sub CPAN::InfoObj::dump ;
5226 sub dump {
5227   my($self, $what) = @_;
5228   unless ($CPAN::META->has_inst("Data::Dumper")) {
5229       $CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
5230   }
5231   local $Data::Dumper::Sortkeys;
5232   $Data::Dumper::Sortkeys = 1;
5233   my $out = Data::Dumper::Dumper($what ? eval $what : $self);
5234   if (length $out > 100000) {
5235       my $fh_pager = FileHandle->new;
5236       local($SIG{PIPE}) = "IGNORE";
5237       my $pager = $CPAN::Config->{'pager'} || "cat";
5238       $fh_pager->open("|$pager")
5239           or die "Could not open pager $pager\: $!";
5240       $fh_pager->print($out);
5241       close $fh_pager;
5242   } else {
5243       $CPAN::Frontend->myprint($out);
5244   }
5245 }
5246
5247 package CPAN::Author;
5248 use strict;
5249
5250 #-> sub CPAN::Author::force
5251 sub force {
5252     my $self = shift;
5253     $self->{force}++;
5254 }
5255
5256 #-> sub CPAN::Author::force
5257 sub unforce {
5258     my $self = shift;
5259     delete $self->{force};
5260 }
5261
5262 #-> sub CPAN::Author::id
5263 sub id {
5264     my $self = shift;
5265     my $id = $self->{ID};
5266     $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
5267     $id;
5268 }
5269
5270 #-> sub CPAN::Author::as_glimpse ;
5271 sub as_glimpse {
5272     my($self) = @_;
5273     my(@m);
5274     my $class = ref($self);
5275     $class =~ s/^CPAN:://;
5276     push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
5277                      $class,
5278                      $self->{ID},
5279                      $self->fullname,
5280                      $self->email);
5281     join "", @m;
5282 }
5283
5284 #-> sub CPAN::Author::fullname ;
5285 sub fullname {
5286     shift->ro->{FULLNAME};
5287 }
5288 *name = \&fullname;
5289
5290 #-> sub CPAN::Author::email ;
5291 sub email    { shift->ro->{EMAIL}; }
5292
5293 #-> sub CPAN::Author::ls ;
5294 sub ls {
5295     my $self = shift;
5296     my $glob = shift || "";
5297     my $silent = shift || 0;
5298     my $id = $self->id;
5299
5300     # adapted from CPAN::Distribution::verifyCHECKSUM ;
5301     my(@csf); # chksumfile
5302     @csf = $self->id =~ /(.)(.)(.*)/;
5303     $csf[1] = join "", @csf[0,1];
5304     $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
5305     my(@dl);
5306     @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
5307     unless (grep {$_->[2] eq $csf[1]} @dl) {
5308         $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
5309         return;
5310     }
5311     @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
5312     unless (grep {$_->[2] eq $csf[2]} @dl) {
5313         $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
5314         return;
5315     }
5316     @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
5317     if ($glob) {
5318         if ($CPAN::META->has_inst("Text::Glob")) {
5319             my $rglob = Text::Glob::glob_to_regex($glob);
5320             @dl = grep { $_->[2] =~ /$rglob/ } @dl;
5321         } else {
5322             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
5323         }
5324     }
5325     $CPAN::Frontend->myprint(join "", map {
5326         sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
5327     } sort { $a->[2] cmp $b->[2] } @dl);
5328     @dl;
5329 }
5330
5331 # returns an array of arrays, the latter contain (size,mtime,filename)
5332 #-> sub CPAN::Author::dir_listing ;
5333 sub dir_listing {
5334     my $self = shift;
5335     my $chksumfile = shift;
5336     my $recursive = shift;
5337     my $may_ftp = shift;
5338
5339     my $lc_want =
5340         File::Spec->catfile($CPAN::Config->{keep_source_where},
5341                             "authors", "id", @$chksumfile);
5342
5343     my $fh;
5344
5345     # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
5346     # hazard.  (Without GPG installed they are not that much better,
5347     # though.)
5348     $fh = FileHandle->new;
5349     if (open($fh, $lc_want)) {
5350         my $line = <$fh>; close $fh;
5351         unlink($lc_want) unless $line =~ /PGP/;
5352     }
5353
5354     local($") = "/";
5355     # connect "force" argument with "index_expire".
5356     my $force = $self->{force};
5357     if (my @stat = stat $lc_want) {
5358         $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
5359     }
5360     my $lc_file;
5361     if ($may_ftp) {
5362         $lc_file = CPAN::FTP->localize(
5363                                        "authors/id/@$chksumfile",
5364                                        $lc_want,
5365                                        $force,
5366                                       );
5367         unless ($lc_file) {
5368             $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
5369             $chksumfile->[-1] .= ".gz";
5370             $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
5371                                            "$lc_want.gz",1);
5372             if ($lc_file) {
5373                 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
5374                 eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
5375             } else {
5376                 return;
5377             }
5378         }
5379     } else {
5380         $lc_file = $lc_want;
5381         # we *could* second-guess and if the user has a file: URL,
5382         # then we could look there. But on the other hand, if they do
5383         # have a file: URL, wy did they choose to set
5384         # $CPAN::Config->{show_upload_date} to false?
5385     }
5386
5387     # adapted from CPAN::Distribution::CHECKSUM_check_file ;
5388     $fh = FileHandle->new;
5389     my($cksum);
5390     if (open $fh, $lc_file){
5391         local($/);
5392         my $eval = <$fh>;
5393         $eval =~ s/\015?\012/\n/g;
5394         close $fh;
5395         my($comp) = Safe->new();
5396         $cksum = $comp->reval($eval);
5397         if ($@) {
5398             rename $lc_file, "$lc_file.bad";
5399             Carp::confess($@) if $@;
5400         }
5401     } elsif ($may_ftp) {
5402         Carp::carp "Could not open '$lc_file' for reading.";
5403     } else {
5404         # Maybe should warn: "You may want to set show_upload_date to a true value"
5405         return;
5406     }
5407     my(@result,$f);
5408     for $f (sort keys %$cksum) {
5409         if (exists $cksum->{$f}{isdir}) {
5410             if ($recursive) {
5411                 my(@dir) = @$chksumfile;
5412                 pop @dir;
5413                 push @dir, $f, "CHECKSUMS";
5414                 push @result, map {
5415                     [$_->[0], $_->[1], "$f/$_->[2]"]
5416                 } $self->dir_listing(\@dir,1,$may_ftp);
5417             } else {
5418                 push @result, [ 0, "-", $f ];
5419             }
5420         } else {
5421             push @result, [
5422                            ($cksum->{$f}{"size"}||0),
5423                            $cksum->{$f}{"mtime"}||"---",
5424                            $f
5425                           ];
5426         }
5427     }
5428     @result;
5429 }
5430
5431 package CPAN::Distribution;
5432 use strict;
5433
5434 # Accessors
5435 sub cpan_comment {
5436     my $self = shift;
5437     my $ro = $self->ro or return;
5438     $ro->{CPAN_COMMENT}
5439 }
5440
5441 # CPAN::Distribution::undelay
5442 sub undelay {
5443     my $self = shift;
5444     delete $self->{later};
5445 }
5446
5447 # add the A/AN/ stuff
5448 # CPAN::Distribution::normalize
5449 sub normalize {
5450     my($self,$s) = @_;
5451     $s = $self->id unless defined $s;
5452     if (substr($s,-1,1) eq ".") {
5453         # using a global because we are sometimes called as static method
5454         if (!$CPAN::META->{LOCK}
5455             && !$CPAN::Have_warned->{"$s is unlocked"}++
5456            ) {
5457             $CPAN::Frontend->mywarn("You are visiting the local directory
5458   '$s'
5459   without lock, take care that concurrent processes do not do likewise.\n");
5460             $CPAN::Frontend->mysleep(1);
5461         }
5462         if ($s eq ".") {
5463             $s = "$CPAN::iCwd/.";
5464         } elsif (File::Spec->file_name_is_absolute($s)) {
5465         } elsif (File::Spec->can("rel2abs")) {
5466             $s = File::Spec->rel2abs($s);
5467         } else {
5468             $CPAN::Frontend->mydie("Your File::Spec is too old, please upgrade File::Spec");
5469         }
5470         CPAN->debug("s[$s]") if $CPAN::DEBUG;
5471         unless ($CPAN::META->exists("CPAN::Distribution", $s)) {
5472             for ($CPAN::META->instance("CPAN::Distribution", $s)) {
5473                 $_->{build_dir} = $s;
5474                 $_->{archived} = "local_directory";
5475                 $_->{unwrapped} = CPAN::Distrostatus->new("YES -- local_directory");
5476             }
5477         }
5478     } elsif (
5479         $s =~ tr|/|| == 1
5480         or
5481         $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
5482        ) {
5483         return $s if $s =~ m:^N/A|^Contact Author: ;
5484         $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
5485             $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
5486         CPAN->debug("s[$s]") if $CPAN::DEBUG;
5487     }
5488     $s;
5489 }
5490
5491 #-> sub CPAN::Distribution::author ;
5492 sub author {
5493     my($self) = @_;
5494     my($authorid);
5495     if (substr($self->id,-1,1) eq ".") {
5496         $authorid = "LOCAL";
5497     } else {
5498         ($authorid) = $self->pretty_id =~ /^([\w\-]+)/;
5499     }
5500     CPAN::Shell->expand("Author",$authorid);
5501 }
5502
5503 # tries to get the yaml from CPAN instead of the distro itself:
5504 # EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels
5505 sub fast_yaml {
5506     my($self) = @_;
5507     my $meta = $self->pretty_id;
5508     $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/;
5509     my(@ls) = CPAN::Shell->globls($meta);
5510     my $norm = $self->normalize($meta);
5511
5512     my($local_file);
5513     my($local_wanted) =
5514         File::Spec->catfile(
5515                             $CPAN::Config->{keep_source_where},
5516                             "authors",
5517                             "id",
5518                             split(/\//,$norm)
5519                            );
5520     $self->debug("Doing localize") if $CPAN::DEBUG;
5521     unless ($local_file =
5522             CPAN::FTP->localize("authors/id/$norm",
5523                                 $local_wanted)) {
5524         $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n");
5525     }
5526     my $yaml = CPAN->_yaml_loadfile($local_file)->[0];
5527 }
5528
5529 #-> sub CPAN::Distribution::cpan_userid
5530 sub cpan_userid {
5531     my $self = shift;
5532     if ($self->{ID} =~ m{[A-Z]/[A-Z\-]{2}/([A-Z\-]+)/}) {
5533         return $1;
5534     }
5535     return $self->SUPER::cpan_userid;
5536 }
5537
5538 #-> sub CPAN::Distribution::pretty_id
5539 sub pretty_id {
5540     my $self = shift;
5541     my $id = $self->id;
5542     return $id unless $id =~ m|^./../|;
5543     substr($id,5);
5544 }
5545
5546 # mark as dirty/clean for the sake of recursion detection. $color=1
5547 # means "in use", $color=0 means "not in use anymore". $color=2 means
5548 # we have determined prereqs now and thus insist on passing this
5549 # through (at least) once again.
5550
5551 #-> sub CPAN::Distribution::color_cmd_tmps ;
5552 sub color_cmd_tmps {
5553     my($self) = shift;
5554     my($depth) = shift || 0;
5555     my($color) = shift || 0;
5556     my($ancestors) = shift || [];
5557     # a distribution needs to recurse into its prereq_pms
5558
5559     return if exists $self->{incommandcolor}
5560         && $color==1
5561         && $self->{incommandcolor}==$color;
5562     if ($depth>=$CPAN::MAX_RECURSION){
5563         die(CPAN::Exception::RecursiveDependency->new($ancestors));
5564     }
5565     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5566     my $prereq_pm = $self->prereq_pm;
5567     if (defined $prereq_pm) {
5568       PREREQ: for my $pre (keys %{$prereq_pm->{requires}||{}},
5569                            keys %{$prereq_pm->{build_requires}||{}}) {
5570             next PREREQ if $pre eq "perl";
5571             my $premo;
5572             unless ($premo = CPAN::Shell->expand("Module",$pre)) {
5573                 $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n");
5574                 $CPAN::Frontend->mysleep(2);
5575                 next PREREQ;
5576             }
5577             $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5578         }
5579     }
5580     if ($color==0) {
5581         delete $self->{sponsored_mods};
5582
5583         # as we are at the end of a command, we'll give up this
5584         # reminder of a broken test. Other commands may test this guy
5585         # again. Maybe 'badtestcnt' should be renamed to
5586         # 'make_test_failed_within_command'?
5587         delete $self->{badtestcnt};
5588     }
5589     $self->{incommandcolor} = $color;
5590 }
5591
5592 #-> sub CPAN::Distribution::as_string ;
5593 sub as_string {
5594   my $self = shift;
5595   $self->containsmods;
5596   $self->upload_date;
5597   $self->SUPER::as_string(@_);
5598 }
5599
5600 #-> sub CPAN::Distribution::containsmods ;
5601 sub containsmods {
5602   my $self = shift;
5603   return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
5604   my $dist_id = $self->{ID};
5605   for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
5606     my $mod_file = $mod->cpan_file or next;
5607     my $mod_id = $mod->{ID} or next;
5608     # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
5609     # sleep 1;
5610     if ($CPAN::Signal) {
5611         delete $self->{CONTAINSMODS};
5612         return;
5613     }
5614     $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
5615   }
5616   keys %{$self->{CONTAINSMODS}||{}};
5617 }
5618
5619 #-> sub CPAN::Distribution::upload_date ;
5620 sub upload_date {
5621   my $self = shift;
5622   return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
5623   my(@local_wanted) = split(/\//,$self->id);
5624   my $filename = pop @local_wanted;
5625   push @local_wanted, "CHECKSUMS";
5626   my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
5627   return unless $author;
5628   my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
5629   return unless @dl;
5630   my($dirent) = grep { $_->[2] eq $filename } @dl;
5631   # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
5632   return unless $dirent->[1];
5633   return $self->{UPLOAD_DATE} = $dirent->[1];
5634 }
5635
5636 #-> sub CPAN::Distribution::uptodate ;
5637 sub uptodate {
5638     my($self) = @_;
5639     my $c;
5640     foreach $c ($self->containsmods) {
5641         my $obj = CPAN::Shell->expandany($c);
5642         unless ($obj->uptodate){
5643             my $id = $self->pretty_id;
5644             $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG;
5645             return 0;
5646         }
5647     }
5648     return 1;
5649 }
5650
5651 #-> sub CPAN::Distribution::called_for ;
5652 sub called_for {
5653     my($self,$id) = @_;
5654     $self->{CALLED_FOR} = $id if defined $id;
5655     return $self->{CALLED_FOR};
5656 }
5657
5658 #-> sub CPAN::Distribution::get ;
5659 sub get {
5660     my($self) = @_;
5661     $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
5662     if (my $goto = $self->prefs->{goto}) {
5663         $CPAN::Frontend->mywarn
5664             (sprintf(
5665                      "delegating to '%s' as specified in prefs file '%s' doc %d\n",
5666                      $goto,
5667                      $self->{prefs_file},
5668                      $self->{prefs_file_doc},
5669                     ));
5670         return $self->goto($goto);
5671     }
5672     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
5673                            ? $ENV{PERL5LIB}
5674                            : ($ENV{PERLLIB} || "");
5675
5676     $CPAN::META->set_perl5lib;
5677     local $ENV{MAKEFLAGS}; # protect us from outer make calls
5678
5679   EXCUSE: {
5680         my @e;
5681         $self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG;
5682         if ($self->prefs->{disabled}) {
5683             my $why = sprintf(
5684                               "Disabled via prefs file '%s' doc %d",
5685                               $self->{prefs_file},
5686                               $self->{prefs_file_doc},
5687                              );
5688             push @e, $why;
5689             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $why");
5690             # note: not intended to be persistent but at least visible
5691             # during this session
5692         } else {
5693             if (exists $self->{build_dir} && -d $self->{build_dir}) {
5694                 # this deserves print, not warn:
5695                 $CPAN::Frontend->myprint("  Has already been unwrapped into directory ".
5696                                          "$self->{build_dir}\n"
5697                                         );
5698                 return;
5699             }
5700
5701             # although we talk about 'force' we shall not test on
5702             # force directly. New model of force tries to refrain from
5703             # direct checking of force.
5704             exists $self->{unwrapped} and (
5705                                            UNIVERSAL::can($self->{unwrapped},"failed") ?
5706                                            $self->{unwrapped}->failed :
5707                                            $self->{unwrapped} =~ /^NO/
5708                                           )
5709                 and push @e, "Unwrapping had some problem, won't try again without force";
5710         }
5711
5712         $CPAN::Frontend->mywarn(join "", map {"$_\n"} @e) and return if @e;
5713     }
5714     my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
5715
5716     #
5717     # Get the file on local disk
5718     #
5719
5720     my($local_file);
5721     my($local_wanted) =
5722         File::Spec->catfile(
5723                             $CPAN::Config->{keep_source_where},
5724                             "authors",
5725                             "id",
5726                             split(/\//,$self->id)
5727                            );
5728
5729     $self->debug("Doing localize") if $CPAN::DEBUG;
5730     unless ($local_file =
5731             CPAN::FTP->localize("authors/id/$self->{ID}",
5732                                 $local_wanted)) {
5733         my $note = "";
5734         if ($CPAN::Index::DATE_OF_02) {
5735             $note = "Note: Current database in memory was generated ".
5736                 "on $CPAN::Index::DATE_OF_02\n";
5737         }
5738         $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
5739     }
5740
5741     $self->debug("local_wanted[$local_wanted]local_file[$local_file]") if $CPAN::DEBUG;
5742     $self->{localfile} = $local_file;
5743     return if $CPAN::Signal;
5744
5745     #
5746     # Check integrity
5747     #
5748     if ($CPAN::META->has_inst("Digest::SHA")) {
5749         $self->debug("Digest::SHA is installed, verifying");
5750         $self->verifyCHECKSUM;
5751     } else {
5752         $self->debug("Digest::SHA is NOT installed");
5753     }
5754     return if $CPAN::Signal;
5755
5756     #
5757     # Create a clean room and go there
5758     #
5759     $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
5760     my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
5761     $self->safe_chdir($builddir);
5762     $self->debug("Removing tmp-$$") if $CPAN::DEBUG;
5763     File::Path::rmtree("tmp-$$");
5764     unless (mkdir "tmp-$$", 0755) {
5765         $CPAN::Frontend->unrecoverable_error(<<EOF);
5766 Couldn't mkdir '$builddir/tmp-$$': $!
5767
5768 Cannot continue: Please find the reason why I cannot make the
5769 directory
5770 $builddir/tmp-$$
5771 and fix the problem, then retry.
5772
5773 EOF
5774     }
5775     if ($CPAN::Signal){
5776         $self->safe_chdir($sub_wd);
5777         return;
5778     }
5779     $self->safe_chdir("tmp-$$");
5780
5781     #
5782     # Unpack the goods
5783     #
5784     my $ct = eval{CPAN::Tarzip->new($local_file)};
5785     unless ($ct) {
5786         $self->{unwrapped} = CPAN::Distrostatus->new("NO");
5787         delete $self->{build_dir};
5788         return;
5789     }
5790     if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i){
5791         $self->{was_uncompressed}++ unless eval{$ct->gtest()};
5792         $self->untar_me($ct);
5793     } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
5794         $self->unzip_me($ct);
5795     } else {
5796         $self->{was_uncompressed}++ unless $ct->gtest();
5797         $local_file = $self->handle_singlefile($local_file);
5798     }
5799
5800     # we are still in the tmp directory!
5801     # Let's check if the package has its own directory.
5802     my $dh = DirHandle->new(File::Spec->curdir)
5803         or Carp::croak("Couldn't opendir .: $!");
5804     my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
5805     $dh->close;
5806     my ($packagedir);
5807     # XXX here we want in each branch File::Temp to protect all build_dir directories
5808     if (CPAN->has_inst("File::Temp")) {
5809         my $tdir_base;
5810         my $from_dir;
5811         my @dirents;
5812         if (@readdir == 1 && -d $readdir[0]) {
5813             $tdir_base = $readdir[0];
5814             $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]);
5815             my $dh2 = DirHandle->new($from_dir)
5816                 or Carp::croak("Couldn't opendir $from_dir: $!");
5817             @dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC??
5818         } else {
5819             my $userid = $self->cpan_userid;
5820             CPAN->debug("userid[$userid]");
5821             if (!$userid or $userid eq "N/A") {
5822                 $userid = "anon";
5823             }
5824             $tdir_base = $userid;
5825             $from_dir = File::Spec->curdir;
5826             @dirents = @readdir;
5827         }
5828         $packagedir = File::Temp::tempdir(
5829                                           "$tdir_base-XXXXXX",
5830                                           DIR => $builddir,
5831                                           CLEANUP => 0,
5832                                          );
5833         my $f;
5834         for $f (@dirents) { # is already without "." and ".."
5835             my $from = File::Spec->catdir($from_dir,$f);
5836             my $to = File::Spec->catdir($packagedir,$f);
5837             unless (File::Copy::move($from,$to)) {
5838                 my $err = $!;
5839                 $from = File::Spec->rel2abs($from);
5840                 Carp::confess("Couldn't move $from to $to: $err");
5841             }
5842         }
5843     } else { # older code below, still better than nothing when there is no File::Temp
5844         my($distdir);
5845         if (@readdir == 1 && -d $readdir[0]) {
5846             $distdir = $readdir[0];
5847             $packagedir = File::Spec->catdir($builddir,$distdir);
5848             $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
5849                 if $CPAN::DEBUG;
5850             -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
5851                                                         "$packagedir\n");
5852             File::Path::rmtree($packagedir);
5853             unless (File::Copy::move($distdir,$packagedir)) {
5854                 $CPAN::Frontend->unrecoverable_error(<<EOF);
5855 Couldn't move '$distdir' to '$packagedir': $!
5856
5857 Cannot continue: Please find the reason why I cannot move
5858 $builddir/tmp-$$/$distdir
5859 to
5860 $packagedir
5861 and fix the problem, then retry
5862
5863 EOF
5864             }
5865             $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
5866                                  $distdir,
5867                                  $packagedir,
5868                                  -e $packagedir,
5869                                  -d $packagedir,
5870                                 )) if $CPAN::DEBUG;
5871         } else {
5872             my $userid = $self->cpan_userid;
5873             CPAN->debug("userid[$userid]") if $CPAN::DEBUG;
5874             if (!$userid or $userid eq "N/A") {
5875                 $userid = "anon";
5876             }
5877             my $pragmatic_dir = $userid . '000';
5878             $pragmatic_dir =~ s/\W_//g;
5879             $pragmatic_dir++ while -d "../$pragmatic_dir";
5880             $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
5881             $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
5882             File::Path::mkpath($packagedir);
5883             my($f);
5884             for $f (@readdir) { # is already without "." and ".."
5885                 my $to = File::Spec->catdir($packagedir,$f);
5886                 File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
5887             }
5888         }
5889     }
5890     if ($CPAN::Signal){
5891         $self->safe_chdir($sub_wd);
5892         return;
5893     }
5894
5895     $self->{build_dir} = $packagedir;
5896     $self->safe_chdir($builddir);
5897     File::Path::rmtree("tmp-$$");
5898
5899     $self->safe_chdir($packagedir);
5900     $self->_signature_business();
5901     $self->safe_chdir($builddir);
5902     return if $CPAN::Signal;
5903
5904
5905     my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
5906     my($mpl_exists) = -f $mpl;
5907     unless ($mpl_exists) {
5908         # NFS has been reported to have racing problems after the
5909         # renaming of a directory in some environments.
5910         # This trick helps.
5911         $CPAN::Frontend->mysleep(1);
5912         my $mpldh = DirHandle->new($packagedir)
5913             or Carp::croak("Couldn't opendir $packagedir: $!");
5914         $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
5915         $mpldh->close;
5916     }
5917     my $prefer_installer = "eumm"; # eumm|mb
5918     if (-f File::Spec->catfile($packagedir,"Build.PL")) {
5919         if ($mpl_exists) { # they *can* choose
5920             if ($CPAN::META->has_inst("Module::Build")) {
5921                 $prefer_installer = CPAN::HandleConfig->prefs_lookup($self,
5922                                                                      q{prefer_installer});
5923             }
5924         } else {
5925             $prefer_installer = "mb";
5926         }
5927     }
5928     return unless $self->patch;
5929     if (lc($prefer_installer) eq "mb") {
5930         $self->{modulebuild} = 1;
5931     } elsif ($self->{archived} eq "patch") {
5932         # not an edge case, nothing to install for sure
5933         my $why = "A patch file cannot be installed";
5934         $CPAN::Frontend->mywarn("Refusing to handle this file: $why\n");
5935         $self->{writemakefile} = CPAN::Distrostatus->new("NO $why");
5936     } elsif (! $mpl_exists) {
5937         $self->_edge_cases($mpl,$packagedir,$local_file);
5938     }
5939     if ($self->{build_dir}
5940         &&
5941         $CPAN::Config->{build_dir_reuse}
5942        ) {
5943         $self->store_persistent_state;
5944     }
5945
5946     return $self;
5947 }
5948
5949 #-> CPAN::Distribution::store_persistent_state
5950 sub store_persistent_state {
5951     my($self) = @_;
5952     my $dir = $self->{build_dir};
5953     unless (File::Spec->canonpath(File::Basename::dirname($dir))
5954             eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
5955         $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
5956                                 "will not store persistent state\n");
5957         return;
5958     }
5959     my $file = sprintf "%s.yml", $dir;
5960     my $yaml_module = CPAN::_yaml_module;
5961     if ($CPAN::META->has_inst($yaml_module)) {
5962         CPAN->_yaml_dumpfile(
5963                              $file,
5964                              {
5965                               time => time,
5966                               perl => CPAN::_perl_fingerprint,
5967                               distribution => $self,
5968                              }
5969                             );
5970     } else {
5971         $CPAN::Frontend->myprint("Warning (usually harmless): '$yaml_module' not installed, ".
5972                                 "will not store persistent state\n");
5973     }
5974 }
5975
5976 #-> CPAN::Distribution::patch
5977 sub try_download {
5978     my($self,$patch) = @_;
5979     my $norm = $self->normalize($patch);
5980     my($local_wanted) =
5981         File::Spec->catfile(
5982                             $CPAN::Config->{keep_source_where},
5983                             "authors",
5984                             "id",
5985                             split(/\//,$norm),
5986                             );
5987     $self->debug("Doing localize") if $CPAN::DEBUG;
5988     return CPAN::FTP->localize("authors/id/$norm",
5989                                $local_wanted);
5990 }
5991
5992 #-> CPAN::Distribution::patch
5993 sub patch {
5994     my($self) = @_;
5995     $self->debug("checking patches id[$self->{ID}]") if $CPAN::DEBUG;
5996     my $patches = $self->prefs->{patches};
5997     $patches ||= "";
5998     $self->debug("patches[$patches]") if $CPAN::DEBUG;
5999     if ($patches) {
6000         return unless @$patches;
6001         $self->safe_chdir($self->{build_dir});
6002         CPAN->debug("patches[$patches]") if $CPAN::DEBUG;
6003         my $patchbin = $CPAN::Config->{patch};
6004         unless ($patchbin && length $patchbin) {
6005             $CPAN::Frontend->mydie("No external patch command configured\n\n".
6006                                    "Please run 'o conf init /patch/'\n\n");
6007         }
6008         unless (MM->maybe_command($patchbin)) {
6009             $CPAN::Frontend->mydie("No external patch command available\n\n".
6010                                    "Please run 'o conf init /patch/'\n\n");
6011         }
6012         $patchbin = CPAN::HandleConfig->safe_quote($patchbin);
6013         local $ENV{PATCH_GET} = 0; # shall replace -g0 which is not
6014                                    # supported everywhere (and then,
6015                                    # not ever necessary there)
6016         my $stdpatchargs = "-N --fuzz=3";
6017         my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches");
6018         $CPAN::Frontend->myprint("Going to apply $countedpatches:\n");
6019         for my $patch (@$patches) {
6020             unless (-f $patch) {
6021                 if (my $trydl = $self->try_download($patch)) {
6022                     $patch = $trydl;
6023                 } else {
6024                     my $fail = "Could not find patch '$patch'";
6025                     $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6026                     $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6027                     delete $self->{build_dir};
6028                     return;
6029                 }
6030             }
6031             $CPAN::Frontend->myprint("  $patch\n");
6032             my $readfh = CPAN::Tarzip->TIEHANDLE($patch);
6033
6034             my $pcommand;
6035             my $ppp = $self->_patch_p_parameter($readfh);
6036             if ($ppp eq "applypatch") {
6037                 $pcommand = "$CPAN::Config->{applypatch} -verbose";
6038             } else {
6039                 my $thispatchargs = join " ", $stdpatchargs, $ppp;
6040                 $pcommand = "$patchbin $thispatchargs";
6041             }
6042
6043             $readfh = CPAN::Tarzip->TIEHANDLE($patch); # open again
6044             my $writefh = FileHandle->new;
6045             $CPAN::Frontend->myprint("  $pcommand\n");
6046             unless (open $writefh, "|$pcommand") {
6047                 my $fail = "Could not fork '$pcommand'";
6048                 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6049                 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6050                 delete $self->{build_dir};
6051                 return;
6052             }
6053             while (my $x = $readfh->READLINE) {
6054                 print $writefh $x;
6055             }
6056             unless (close $writefh) {
6057                 my $fail = "Could not apply patch '$patch'";
6058                 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6059                 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6060                 delete $self->{build_dir};
6061                 return;
6062             }
6063         }
6064         $self->{patched}++;
6065     }
6066     return 1;
6067 }
6068
6069 sub _patch_p_parameter {
6070     my($self,$fh) = @_;
6071     my $cnt_files   = 0;
6072     my $cnt_p0files = 0;
6073     local($_);
6074     while ($_ = $fh->READLINE) {
6075         if (
6076             $CPAN::Config->{applypatch}
6077             &&
6078             /\#\#\#\# ApplyPatch data follows \#\#\#\#/
6079            ) {
6080             return "applypatch"
6081         }
6082         next unless /^[\*\+]{3}\s(\S+)/;
6083         my $file = $1;
6084         $cnt_files++;
6085         $cnt_p0files++ if -f $file;
6086         CPAN->debug("file[$file]cnt_files[$cnt_files]cnt_p0files[$cnt_p0files]")
6087             if $CPAN::DEBUG;
6088     }
6089     return "-p1" unless $cnt_files;
6090     return $cnt_files==$cnt_p0files ? "-p0" : "-p1";
6091 }
6092
6093 #-> sub CPAN::Distribution::_edge_cases
6094 # with "configure" or "Makefile" or single file scripts
6095 sub _edge_cases {
6096     my($self,$mpl,$packagedir,$local_file) = @_;
6097     $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
6098                          $mpl,
6099                          CPAN::anycwd(),
6100                         )) if $CPAN::DEBUG;
6101     my($configure) = File::Spec->catfile($packagedir,"Configure");
6102     if (-f $configure) {
6103         # do we have anything to do?
6104         $self->{configure} = $configure;
6105     } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
6106         $CPAN::Frontend->mywarn(qq{
6107 Package comes with a Makefile and without a Makefile.PL.
6108 We\'ll try to build it with that Makefile then.
6109 });
6110         $self->{writemakefile} = CPAN::Distrostatus->new("YES");
6111         $CPAN::Frontend->mysleep(2);
6112     } else {
6113         my $cf = $self->called_for || "unknown";
6114         if ($cf =~ m|/|) {
6115             $cf =~ s|.*/||;
6116             $cf =~ s|\W.*||;
6117         }
6118         $cf =~ s|[/\\:]||g;     # risk of filesystem damage
6119         $cf = "unknown" unless length($cf);
6120         $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
6121   (The test -f "$mpl" returned false.)
6122   Writing one on our own (setting NAME to $cf)\a\n});
6123         $self->{had_no_makefile_pl}++;
6124         $CPAN::Frontend->mysleep(3);
6125
6126         # Writing our own Makefile.PL
6127
6128         my $script = "";
6129         if ($self->{archived} eq "maybe_pl") {
6130             my $fh = FileHandle->new;
6131             my $script_file = File::Spec->catfile($packagedir,$local_file);
6132             $fh->open($script_file)
6133                 or Carp::croak("Could not open $script_file: $!");
6134             local $/ = "\n";
6135             # name parsen und prereq
6136             my($state) = "poddir";
6137             my($name, $prereq) = ("", "");
6138             while (<$fh>) {
6139                 if ($state eq "poddir" && /^=head\d\s+(\S+)/) {
6140                     if ($1 eq 'NAME') {
6141                         $state = "name";
6142                     } elsif ($1 eq 'PREREQUISITES') {
6143                         $state = "prereq";
6144                     }
6145                 } elsif ($state =~ m{^(name|prereq)$}) {
6146                     if (/^=/) {
6147                         $state = "poddir";
6148                     } elsif (/^\s*$/) {
6149                         # nop
6150                     } elsif ($state eq "name") {
6151                         if ($name eq "") {
6152                             ($name) = /^(\S+)/;
6153                             $state = "poddir";
6154                         }
6155                     } elsif ($state eq "prereq") {
6156                         $prereq .= $_;
6157                     }
6158                 } elsif (/^=cut\b/) {
6159                     last;
6160                 }
6161             }
6162             $fh->close;
6163
6164             for ($name) {
6165                 s{.*<}{};       # strip X<...>
6166                 s{>.*}{};
6167             }
6168             chomp $prereq;
6169             $prereq = join " ", split /\s+/, $prereq;
6170             my($PREREQ_PM) = join("\n", map {
6171                 s{.*<}{};       # strip X<...>
6172                 s{>.*}{};
6173                 if (/[\s\'\"]/) { # prose?
6174                 } else {
6175                     s/[^\w:]$//; # period?
6176                     " "x28 . "'$_' => 0,";
6177                 }
6178             } split /\s*,\s*/, $prereq);
6179
6180             $script = "
6181               EXE_FILES => ['$name'],
6182               PREREQ_PM => {
6183 $PREREQ_PM
6184                            },
6185 ";
6186             if ($name) {
6187                 my $to_file = File::Spec->catfile($packagedir, $name);
6188                 rename $script_file, $to_file
6189                     or die "Can't rename $script_file to $to_file: $!";
6190             }
6191         }
6192
6193         my $fh = FileHandle->new;
6194         $fh->open(">$mpl")
6195             or Carp::croak("Could not open >$mpl: $!");
6196         $fh->print(
6197                    qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
6198 # because there was no Makefile.PL supplied.
6199 # Autogenerated on: }.scalar localtime().qq{
6200
6201 use ExtUtils::MakeMaker;
6202 WriteMakefile(
6203               NAME => q[$cf],$script
6204              );
6205 });
6206         $fh->close;
6207     }
6208 }
6209
6210 #-> CPAN::Distribution::_signature_business
6211 sub _signature_business {
6212     my($self) = @_;
6213     my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
6214                                                       q{check_sigs});
6215     if ($check_sigs) {
6216         if ($CPAN::META->has_inst("Module::Signature")) {
6217             if (-f "SIGNATURE") {
6218                 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
6219                 my $rv = Module::Signature::verify();
6220                 if ($rv != Module::Signature::SIGNATURE_OK() and
6221                     $rv != Module::Signature::SIGNATURE_MISSING()) {
6222                     $CPAN::Frontend->mywarn(
6223                                             qq{\nSignature invalid for }.
6224                                             qq{distribution file. }.
6225                                             qq{Please investigate.\n\n}
6226                                            );
6227
6228                     my $wrap =
6229                         sprintf(qq{I'd recommend removing %s. Its signature
6230 is invalid. Maybe you have configured your 'urllist' with
6231 a bad URL. Please check this array with 'o conf urllist', and
6232 retry. For more information, try opening a subshell with
6233   look %s
6234 and there run
6235   cpansign -v
6236 },
6237                                 $self->{localfile},
6238                                 $self->pretty_id,
6239                                );
6240                     $self->{signature_verify} = CPAN::Distrostatus->new("NO");
6241                     $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
6242                     $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
6243                 } else {
6244                     $self->{signature_verify} = CPAN::Distrostatus->new("YES");
6245                     $self->debug("Module::Signature has verified") if $CPAN::DEBUG;
6246                 }
6247             } else {
6248                 $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n});
6249             }
6250         } else {
6251             $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
6252         }
6253     }
6254 }
6255
6256 #-> CPAN::Distribution::untar_me ;
6257 sub untar_me {
6258     my($self,$ct) = @_;
6259     $self->{archived} = "tar";
6260     if ($ct->untar()) {
6261         $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6262     } else {
6263         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed");
6264     }
6265 }
6266
6267 # CPAN::Distribution::unzip_me ;
6268 sub unzip_me {
6269     my($self,$ct) = @_;
6270     $self->{archived} = "zip";
6271     if ($ct->unzip()) {
6272         $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6273     } else {
6274         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed");
6275     }
6276     return;
6277 }
6278
6279 sub handle_singlefile {
6280     my($self,$local_file) = @_;
6281
6282     if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ){
6283         $self->{archived} = "pm";
6284     } elsif ( $local_file =~ /\.patch(\.(gz|bz2))?(?!\n)\Z/ ) {
6285         $self->{archived} = "patch";
6286     } else {
6287         $self->{archived} = "maybe_pl";
6288     }
6289
6290     my $to = File::Basename::basename($local_file);
6291     if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
6292         if (eval{CPAN::Tarzip->new($local_file)->gunzip($to)}) {
6293             $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6294         } else {
6295             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- uncompressing failed");
6296         }
6297     } else {
6298         if (File::Copy::cp($local_file,".")) {
6299             $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6300         } else {
6301             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed");
6302         }
6303     }
6304     return $to;
6305 }
6306
6307 #-> sub CPAN::Distribution::new ;
6308 sub new {
6309     my($class,%att) = @_;
6310
6311     # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
6312
6313     my $this = { %att };
6314     return bless $this, $class;
6315 }
6316
6317 #-> sub CPAN::Distribution::look ;
6318 sub look {
6319     my($self) = @_;
6320
6321     if ($^O eq 'MacOS') {
6322       $self->Mac::BuildTools::look;
6323       return;
6324     }
6325
6326     if (  $CPAN::Config->{'shell'} ) {
6327         $CPAN::Frontend->myprint(qq{
6328 Trying to open a subshell in the build directory...
6329 });
6330     } else {
6331         $CPAN::Frontend->myprint(qq{
6332 Your configuration does not define a value for subshells.
6333 Please define it with "o conf shell <your shell>"
6334 });
6335         return;
6336     }
6337     my $dist = $self->id;
6338     my $dir;
6339     unless ($dir = $self->dir) {
6340         $self->get;
6341     }
6342     unless ($dir ||= $self->dir) {
6343         $CPAN::Frontend->mywarn(qq{
6344 Could not determine which directory to use for looking at $dist.
6345 });
6346         return;
6347     }
6348     my $pwd  = CPAN::anycwd();
6349     $self->safe_chdir($dir);
6350     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
6351     {
6352         local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
6353         $ENV{CPAN_SHELL_LEVEL} += 1;
6354         my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'});
6355         unless (system($shell) == 0) {
6356             my $code = $? >> 8;
6357             $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
6358         }
6359     }
6360     $self->safe_chdir($pwd);
6361 }
6362
6363 # CPAN::Distribution::cvs_import ;
6364 sub cvs_import {
6365     my($self) = @_;
6366     $self->get;
6367     my $dir = $self->dir;
6368
6369     my $package = $self->called_for;
6370     my $module = $CPAN::META->instance('CPAN::Module', $package);
6371     my $version = $module->cpan_version;
6372
6373     my $userid = $self->cpan_userid;
6374
6375     my $cvs_dir = (split /\//, $dir)[-1];
6376     $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
6377     my $cvs_root =
6378       $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
6379     my $cvs_site_perl =
6380       $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
6381     if ($cvs_site_perl) {
6382         $cvs_dir = "$cvs_site_perl/$cvs_dir";
6383     }
6384     my $cvs_log = qq{"imported $package $version sources"};
6385     $version =~ s/\./_/g;
6386     # XXX cvs: undocumented and unclear how it was meant to work
6387     my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
6388                "$cvs_dir", $userid, "v$version");
6389
6390     my $pwd  = CPAN::anycwd();
6391     chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
6392
6393     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
6394
6395     $CPAN::Frontend->myprint(qq{@cmd\n});
6396     system(@cmd) == 0 or
6397     # XXX cvs
6398         $CPAN::Frontend->mydie("cvs import failed");
6399     chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
6400 }
6401
6402 #-> sub CPAN::Distribution::readme ;
6403 sub readme {
6404     my($self) = @_;
6405     my($dist) = $self->id;
6406     my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
6407     $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
6408     my($local_file);
6409     my($local_wanted) =
6410          File::Spec->catfile(
6411                              $CPAN::Config->{keep_source_where},
6412                              "authors",
6413                              "id",
6414                              split(/\//,"$sans.readme"),
6415                             );
6416     $self->debug("Doing localize") if $CPAN::DEBUG;
6417     $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
6418                                       $local_wanted)
6419         or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
6420
6421     if ($^O eq 'MacOS') {
6422         Mac::BuildTools::launch_file($local_file);
6423         return;
6424     }
6425
6426     my $fh_pager = FileHandle->new;
6427     local($SIG{PIPE}) = "IGNORE";
6428     my $pager = $CPAN::Config->{'pager'} || "cat";
6429     $fh_pager->open("|$pager")
6430         or die "Could not open pager $pager\: $!";
6431     my $fh_readme = FileHandle->new;
6432     $fh_readme->open($local_file)
6433         or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
6434     $CPAN::Frontend->myprint(qq{
6435 Displaying file
6436   $local_file
6437 with pager "$pager"
6438 });
6439     $fh_pager->print(<$fh_readme>);
6440     $fh_pager->close;
6441 }
6442
6443 #-> sub CPAN::Distribution::verifyCHECKSUM ;
6444 sub verifyCHECKSUM {
6445     my($self) = @_;
6446   EXCUSE: {
6447         my @e;
6448         $self->{CHECKSUM_STATUS} ||= "";
6449         $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
6450         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
6451     }
6452     my($lc_want,$lc_file,@local,$basename);
6453     @local = split(/\//,$self->id);
6454     pop @local;
6455     push @local, "CHECKSUMS";
6456     $lc_want =
6457         File::Spec->catfile($CPAN::Config->{keep_source_where},
6458                             "authors", "id", @local);
6459     local($") = "/";
6460     if (my $size = -s $lc_want) {
6461         $self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG;
6462         if ($self->CHECKSUM_check_file($lc_want,1)) {
6463             return $self->{CHECKSUM_STATUS} = "OK";
6464         }
6465     }
6466     $lc_file = CPAN::FTP->localize("authors/id/@local",
6467                                    $lc_want,1);
6468     unless ($lc_file) {
6469         $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
6470         $local[-1] .= ".gz";
6471         $lc_file = CPAN::FTP->localize("authors/id/@local",
6472                                        "$lc_want.gz",1);
6473         if ($lc_file) {
6474             $lc_file =~ s/\.gz(?!\n)\Z//;
6475             eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
6476         } else {
6477             return;
6478         }
6479     }
6480     if ($self->CHECKSUM_check_file($lc_file)) {
6481         return $self->{CHECKSUM_STATUS} = "OK";
6482     }
6483 }
6484
6485 #-> sub CPAN::Distribution::SIG_check_file ;
6486 sub SIG_check_file {
6487     my($self,$chk_file) = @_;
6488     my $rv = eval { Module::Signature::_verify($chk_file) };
6489
6490     if ($rv == Module::Signature::SIGNATURE_OK()) {
6491         $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
6492         return $self->{SIG_STATUS} = "OK";
6493     } else {
6494         $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
6495                                  qq{distribution file. }.
6496                                  qq{Please investigate.\n\n}.
6497                                  $self->as_string,
6498                                 $CPAN::META->instance(
6499                                                         'CPAN::Author',
6500                                                         $self->cpan_userid
6501                                                         )->as_string);
6502
6503         my $wrap = qq{I\'d recommend removing $chk_file. Its signature
6504 is invalid. Maybe you have configured your 'urllist' with
6505 a bad URL. Please check this array with 'o conf urllist', and
6506 retry.};
6507
6508         $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
6509     }
6510 }
6511
6512 #-> sub CPAN::Distribution::CHECKSUM_check_file ;
6513
6514 # sloppy is 1 when we have an old checksums file that maybe is good
6515 # enough
6516
6517 sub CHECKSUM_check_file {
6518     my($self,$chk_file,$sloppy) = @_;
6519     my($cksum,$file,$basename);
6520
6521     $sloppy ||= 0;
6522     $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG;
6523     my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
6524                                                       q{check_sigs});
6525     if ($check_sigs) {
6526         if ($CPAN::META->has_inst("Module::Signature")) {
6527             $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
6528             $self->SIG_check_file($chk_file);
6529         } else {
6530             $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
6531         }
6532     }
6533
6534     $file = $self->{localfile};
6535     $basename = File::Basename::basename($file);
6536     my $fh = FileHandle->new;
6537     if (open $fh, $chk_file){
6538         local($/);
6539         my $eval = <$fh>;
6540         $eval =~ s/\015?\012/\n/g;
6541         close $fh;
6542         my($comp) = Safe->new();
6543         $cksum = $comp->reval($eval);
6544         if ($@) {
6545             rename $chk_file, "$chk_file.bad";
6546             Carp::confess($@) if $@;
6547         }
6548     } else {
6549         Carp::carp "Could not open $chk_file for reading";
6550     }
6551
6552     if (! ref $cksum or ref $cksum ne "HASH") {
6553         $CPAN::Frontend->mywarn(qq{
6554 Warning: checksum file '$chk_file' broken.
6555
6556 When trying to read that file I expected to get a hash reference
6557 for further processing, but got garbage instead.
6558 });
6559         my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
6560         $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
6561         $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken";
6562         return;
6563     } elsif (exists $cksum->{$basename}{sha256}) {
6564         $self->debug("Found checksum for $basename:" .
6565                      "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
6566
6567         open($fh, $file);
6568         binmode $fh;
6569         my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
6570         $fh->close;
6571         $fh = CPAN::Tarzip->TIEHANDLE($file);
6572
6573         unless ($eq) {
6574           my $dg = Digest::SHA->new(256);
6575           my($data,$ref);
6576           $ref = \$data;
6577           while ($fh->READ($ref, 4096) > 0){
6578             $dg->add($data);
6579           }
6580           my $hexdigest = $dg->hexdigest;
6581           $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
6582         }
6583
6584         if ($eq) {
6585           $CPAN::Frontend->myprint("Checksum for $file ok\n");
6586           return $self->{CHECKSUM_STATUS} = "OK";
6587         } else {
6588             $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
6589                                      qq{distribution file. }.
6590                                      qq{Please investigate.\n\n}.
6591                                      $self->as_string,
6592                                      $CPAN::META->instance(
6593                                                            'CPAN::Author',
6594                                                            $self->cpan_userid
6595                                                           )->as_string);
6596
6597             my $wrap = qq{I\'d recommend removing $file. Its
6598 checksum is incorrect. Maybe you have configured your 'urllist' with
6599 a bad URL. Please check this array with 'o conf urllist', and
6600 retry.};
6601
6602             $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
6603
6604             # former versions just returned here but this seems a
6605             # serious threat that deserves a die
6606
6607             # $CPAN::Frontend->myprint("\n\n");
6608             # sleep 3;
6609             # return;
6610         }
6611         # close $fh if fileno($fh);
6612     } else {
6613         return if $sloppy;
6614         unless ($self->{CHECKSUM_STATUS}) {
6615             $CPAN::Frontend->mywarn(qq{
6616 Warning: No checksum for $basename in $chk_file.
6617
6618 The cause for this may be that the file is very new and the checksum
6619 has not yet been calculated, but it may also be that something is
6620 going awry right now.
6621 });
6622             my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes");
6623             $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
6624         }
6625         $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file";
6626         return;
6627     }
6628 }
6629
6630 #-> sub CPAN::Distribution::eq_CHECKSUM ;
6631 sub eq_CHECKSUM {
6632     my($self,$fh,$expect) = @_;
6633     if ($CPAN::META->has_inst("Digest::SHA")) {
6634         my $dg = Digest::SHA->new(256);
6635         my($data);
6636         while (read($fh, $data, 4096)){
6637             $dg->add($data);
6638         }
6639         my $hexdigest = $dg->hexdigest;
6640         # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
6641         return $hexdigest eq $expect;
6642     }
6643     return 1;
6644 }
6645
6646 #-> sub CPAN::Distribution::force ;
6647
6648 # Both CPAN::Modules and CPAN::Distributions know if "force" is in
6649 # effect by autoinspection, not by inspecting a global variable. One
6650 # of the reason why this was chosen to work that way was the treatment
6651 # of dependencies. They should not automatically inherit the force
6652 # status. But this has the downside that ^C and die() will return to
6653 # the prompt but will not be able to reset the force_update
6654 # attributes. We try to correct for it currently in the read_metadata
6655 # routine, and immediately before we check for a Signal. I hope this
6656 # works out in one of v1.57_53ff
6657
6658 # "Force get forgets previous error conditions"
6659
6660 #-> sub CPAN::Distribution::fforce ;
6661 sub fforce {
6662   my($self, $method) = @_;
6663   $self->force($method,1);
6664 }
6665
6666 #-> sub CPAN::Distribution::force ;
6667 sub force {
6668   my($self, $method,$fforce) = @_;
6669   my %phase_map = (
6670                    get => [
6671                            "unwrapped",
6672                            "build_dir",
6673                            "archived",
6674                            "localfile",
6675                            "CHECKSUM_STATUS",
6676                            "signature_verify",
6677                            "prefs",
6678                            "prefs_file",
6679                            "prefs_file_doc",
6680                           ],
6681                    make => [
6682                             "writemakefile",
6683                             "make",
6684                             "modulebuild",
6685                             "prereq_pm",
6686                             "prereq_pm_detected",
6687                            ],
6688                    test => [
6689                             "badtestcnt",
6690                             "make_test",
6691                            ],
6692                    install => [
6693                                "install",
6694                               ],
6695                    unknown => [
6696                                "reqtype",
6697                                "yaml_content",
6698                               ],
6699                   );
6700   my $methodmatch = 0;
6701   my $ldebug = 0;
6702  PHASE: for my $phase (qw(unknown get make test install)) { # order matters
6703       $methodmatch = 1 if $fforce || $phase eq $method;
6704       next unless $methodmatch;
6705     ATTRIBUTE: for my $att (@{$phase_map{$phase}}) {
6706           if ($phase eq "get") {
6707               if (substr($self->id,-1,1) eq "."
6708                   && $att =~ /(unwrapped|build_dir|archived)/ ) {
6709                   # cannot be undone for local distros
6710                   next ATTRIBUTE;
6711               }
6712               if ($att eq "build_dir"
6713                   && $self->{build_dir}
6714                   && $CPAN::META->{is_tested}
6715                  ) {
6716                   delete $CPAN::META->{is_tested}{$self->{build_dir}};
6717               }
6718           } elsif ($phase eq "test") {
6719               if ($att eq "make_test"
6720                   && $self->{make_test}
6721                   && $self->{make_test}{COMMANDID}
6722                   && $self->{make_test}{COMMANDID} == $CPAN::CurrentCommandId
6723                  ) {
6724                   # endless loop too likely
6725                   next ATTRIBUTE;
6726               }
6727           }
6728           delete $self->{$att};
6729           if ($ldebug || $CPAN::DEBUG) {
6730               # local $CPAN::DEBUG = 16; # Distribution
6731               CPAN->debug(sprintf "id[%s]phase[%s]att[%s]", $self->id, $phase, $att);
6732           }
6733       }
6734   }
6735   if ($method && $method =~ /make|test|install/) {
6736     $self->{force_update} = 1; # name should probably have been force_install
6737   }
6738 }
6739
6740 #-> sub CPAN::Distribution::notest ;
6741 sub notest {
6742   my($self, $method) = @_;
6743   # warn "XDEBUG: set notest for $self $method";
6744   $self->{"notest"}++; # name should probably have been force_install
6745 }
6746
6747 #-> sub CPAN::Distribution::unnotest ;
6748 sub unnotest {
6749   my($self) = @_;
6750   # warn "XDEBUG: deleting notest";
6751   delete $self->{'notest'};
6752 }
6753
6754 #-> sub CPAN::Distribution::unforce ;
6755 sub unforce {
6756   my($self) = @_;
6757   delete $self->{force_update};
6758 }
6759
6760 #-> sub CPAN::Distribution::isa_perl ;
6761 sub isa_perl {
6762   my($self) = @_;
6763   my $file = File::Basename::basename($self->id);
6764   if ($file =~ m{ ^ perl
6765                   -?
6766                   (5)
6767                   ([._-])
6768                   (
6769                    \d{3}(_[0-4][0-9])?
6770                    |
6771                    \d+\.\d+
6772                   )
6773                   \.tar[._-](?:gz|bz2)
6774                   (?!\n)\Z
6775                 }xs){
6776     return "$1.$3";
6777   } elsif ($self->cpan_comment
6778            &&
6779            $self->cpan_comment =~ /isa_perl\(.+?\)/){
6780     return $1;
6781   }
6782 }
6783
6784
6785 #-> sub CPAN::Distribution::perl ;
6786 sub perl {
6787     my ($self) = @_;
6788     if (! $self) {
6789         use Carp qw(carp);
6790         carp __PACKAGE__ . "::perl was called without parameters.";
6791     }
6792     return CPAN::HandleConfig->safe_quote($CPAN::Perl);
6793 }
6794
6795
6796 #-> sub CPAN::Distribution::make ;
6797 sub make {
6798     my($self) = @_;
6799     if (my $goto = $self->prefs->{goto}) {
6800         return $self->goto($goto);
6801     }
6802     my $make = $self->{modulebuild} ? "Build" : "make";
6803     # Emergency brake if they said install Pippi and get newest perl
6804     if ($self->isa_perl) {
6805       if (
6806           $self->called_for ne $self->id &&
6807           ! $self->{force_update}
6808          ) {
6809         # if we die here, we break bundles
6810         $CPAN::Frontend
6811             ->mywarn(sprintf(
6812                              qq{The most recent version "%s" of the module "%s"
6813 is part of the perl-%s distribution. To install that, you need to run
6814   force install %s   --or--
6815   install %s
6816 },
6817                              $CPAN::META->instance(
6818                                                    'CPAN::Module',
6819                                                    $self->called_for
6820                                                   )->cpan_version,
6821                              $self->called_for,
6822                              $self->isa_perl,
6823                              $self->called_for,
6824                              $self->id,
6825                             ));
6826         $self->{make} = CPAN::Distrostatus->new("NO isa perl");
6827         $CPAN::Frontend->mysleep(1);
6828         return;
6829       }
6830     }
6831     $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
6832     $self->get;
6833     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
6834                            ? $ENV{PERL5LIB}
6835                            : ($ENV{PERLLIB} || "");
6836     $CPAN::META->set_perl5lib;
6837     local $ENV{MAKEFLAGS}; # protect us from outer make calls
6838
6839     if ($CPAN::Signal){
6840       delete $self->{force_update};
6841       return;
6842     }
6843
6844     my $builddir;
6845   EXCUSE: {
6846         my @e;
6847         if (!$self->{archived} || $self->{archived} eq "NO") {
6848             push @e, "Is neither a tar nor a zip archive.";
6849         }
6850
6851         if (!$self->{unwrapped}
6852             || (
6853                 UNIVERSAL::can($self->{unwrapped},"failed") ?
6854                 $self->{unwrapped}->failed :
6855                 $self->{unwrapped} =~ /^NO/
6856                )) {
6857             push @e, "Had problems unarchiving. Please build manually";
6858         }
6859
6860         unless ($self->{force_update}) {
6861             exists $self->{signature_verify} and
6862                 (
6863                  UNIVERSAL::can($self->{signature_verify},"failed") ?
6864                  $self->{signature_verify}->failed :
6865                  $self->{signature_verify} =~ /^NO/
6866                 )
6867                 and push @e, "Did not pass the signature test.";
6868         }
6869
6870         if (exists $self->{writemakefile} &&
6871             (
6872              UNIVERSAL::can($self->{writemakefile},"failed") ?
6873              $self->{writemakefile}->failed :
6874              $self->{writemakefile} =~ /^NO/
6875             )) {
6876             # XXX maybe a retry would be in order?
6877             my $err = UNIVERSAL::can($self->{writemakefile},"text") ?
6878                 $self->{writemakefile}->text :
6879                     $self->{writemakefile};
6880             $err =~ s/^NO\s*//;
6881             $err ||= "Had some problem writing Makefile";
6882             $err .= ", won't make";
6883             push @e, $err;
6884         }
6885
6886         if (defined $self->{make}) {
6887             if ($self->{make}->failed) {
6888                 if ($self->{force_update}) {
6889                     # Trying an already failed 'make' (unless somebody else blocks)
6890                 } else {
6891                     # introduced for turning recursion detection into a distrostatus
6892                     $CPAN::Frontend->mywarn("Could not make: ".substr($self->{make},3)."\n");
6893                     $self->store_persistent_state;
6894                     return;
6895                 }
6896             } else {
6897                 push @e, "Has already been made";
6898             }
6899         }
6900
6901         if (exists $self->{later} and length($self->{later})) {
6902             if ($self->unsat_prereq) {
6903                 push @e, $self->{later};
6904 # RT ticket 18438 raises doubts if the deletion of {later} is valid.
6905 # YAML-0.53 triggered the later hodge-podge here, but my margin notes
6906 # are not sufficient to be sure if we really must/may do the delete
6907 # here. SO I accept the suggested patch for now. If we trigger a bug
6908 # again, I must go into deep contemplation about the {later} flag.
6909
6910 #            } else {
6911 #                delete $self->{later};
6912             }
6913         }
6914
6915         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
6916         $builddir = $self->dir or
6917             $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
6918         unless (chdir $builddir) {
6919             push @e, "Couldn't chdir to '$builddir': $!";
6920         }
6921         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
6922     }
6923     if ($CPAN::Signal){
6924       delete $self->{force_update};
6925       return;
6926     }
6927     $CPAN::Frontend->myprint("\n  CPAN.pm: Going to build ".$self->id."\n\n");
6928     $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
6929
6930     if ($^O eq 'MacOS') {
6931         Mac::BuildTools::make($self);
6932         return;
6933     }
6934
6935     my %env;
6936     while (my($k,$v) = each %ENV) {
6937         next unless defined $v;
6938         $env{$k} = $v;
6939     }
6940     local %ENV = %env;
6941     my $system;
6942     if (my $commandline = $self->prefs->{pl}{commandline}) {
6943         $system = $commandline;
6944         $ENV{PERL} = $^X;
6945     } elsif ($self->{'configure'}) {
6946         $system = $self->{'configure'};
6947     } elsif ($self->{modulebuild}) {
6948         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
6949         $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}";
6950     } else {
6951         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
6952         my $switch = "";
6953 # This needs a handler that can be turned on or off:
6954 #       $switch = "-MExtUtils::MakeMaker ".
6955 #           "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
6956 #           if $] > 5.00310;
6957         my $makepl_arg = $self->make_x_arg("pl");
6958         $system = sprintf("%s%s Makefile.PL%s",
6959                           $perl,
6960                           $switch ? " $switch" : "",
6961                           $makepl_arg ? " $makepl_arg" : "",
6962                          );
6963     }
6964     if (my $env = $self->prefs->{pl}{env}) {
6965         for my $e (keys %$env) {
6966             $ENV{$e} = $env->{$e};
6967         }
6968     }
6969     if (exists $self->{writemakefile}) {
6970     } else {
6971         local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
6972         my($ret,$pid);
6973         $@ = "";
6974         my $go_via_alarm;
6975         if ($CPAN::Config->{inactivity_timeout}) {
6976             require Config;
6977             if ($Config::Config{d_alarm}
6978                 &&
6979                 $Config::Config{d_alarm} eq "define"
6980                ) {
6981                 $go_via_alarm++
6982             } else {
6983                 $CPAN::Frontend->mywarn("Warning: you have configured the config ".
6984                                         "variable 'inactivity_timeout' to ".
6985                                         "'$CPAN::Config->{inactivity_timeout}'. But ".
6986                                         "on this machine the system call 'alarm' ".
6987                                         "isn't available. This means that we cannot ".
6988                                         "provide the feature of intercepting long ".
6989                                         "waiting code and will turn this feature off.\n"
6990                                        );
6991                 $CPAN::Config->{inactivity_timeout} = 0;
6992             }
6993         }
6994         if ($go_via_alarm) {
6995             eval {
6996                 alarm $CPAN::Config->{inactivity_timeout};
6997                 local $SIG{CHLD}; # = sub { wait };
6998                 if (defined($pid = fork)) {
6999                     if ($pid) { #parent
7000                         # wait;
7001                         waitpid $pid, 0;
7002                     } else {    #child
7003                         # note, this exec isn't necessary if
7004                         # inactivity_timeout is 0. On the Mac I'd
7005                         # suggest, we set it always to 0.
7006                         exec $system;
7007                     }
7008                 } else {
7009                     $CPAN::Frontend->myprint("Cannot fork: $!");
7010                     return;
7011                 }
7012             };
7013             alarm 0;
7014             if ($@){
7015                 kill 9, $pid;
7016                 waitpid $pid, 0;
7017                 my $err = "$@";
7018                 $CPAN::Frontend->myprint($err);
7019                 $self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
7020                 $@ = "";
7021                 return;
7022             }
7023         } else {
7024             if (my $expect_model = $self->_prefs_with_expect("pl")) {
7025                 $ret = $self->_run_via_expect($system,$expect_model);
7026                 if (! defined $ret
7027                     && $self->{writemakefile}
7028                     && $self->{writemakefile}->failed) {
7029                     # timeout
7030                     return;
7031                 }
7032             } else {
7033                 $ret = system($system);
7034             }
7035             if ($ret != 0) {
7036                 $self->{writemakefile} = CPAN::Distrostatus
7037                     ->new("NO '$system' returned status $ret");
7038                 $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
7039                 $self->store_persistent_state;
7040                 return;
7041             }
7042         }
7043         if (-f "Makefile" || -f "Build") {
7044           $self->{writemakefile} = CPAN::Distrostatus->new("YES");
7045           delete $self->{make_clean}; # if cleaned before, enable next
7046         } else {
7047           $self->{writemakefile} = CPAN::Distrostatus
7048               ->new(qq{NO -- Unknown reason});
7049         }
7050     }
7051     if ($CPAN::Signal){
7052       delete $self->{force_update};
7053       return;
7054     }
7055     if (my @prereq = $self->unsat_prereq){
7056         if ($prereq[0][0] eq "perl") {
7057             my $need = "requires perl '$prereq[0][1]'";
7058             my $id = $self->pretty_id;
7059             $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
7060             $self->{make} = CPAN::Distrostatus->new("NO $need");
7061             $self->store_persistent_state;
7062             return;
7063         } else {
7064             my $follow = eval { $self->follow_prereqs(@prereq); };
7065             if (0) {
7066             } elsif ($follow){
7067                 # signal success to the queuerunner
7068                 return 1;
7069             } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
7070                 $CPAN::Frontend->mywarn($@);
7071                 return;
7072             }
7073         }
7074     }
7075     if ($CPAN::Signal){
7076       delete $self->{force_update};
7077       return;
7078     }
7079     if (my $commandline = $self->prefs->{make}{commandline}) {
7080         $system = $commandline;
7081         $ENV{PERL} = $^X;
7082     } else {
7083         if ($self->{modulebuild}) {
7084             unless (-f "Build") {
7085                 my $cwd = CPAN::anycwd();
7086                 $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
7087                                         " in cwd[$cwd]. Danger, Will Robinson!");
7088                 $CPAN::Frontend->mysleep(5);
7089             }
7090             $system = join " ", $self->_build_command(), $CPAN::Config->{mbuild_arg};
7091         } else {
7092             $system = join " ", $self->_make_command(),  $CPAN::Config->{make_arg};
7093         }
7094         $system =~ s/\s+$//;
7095         my $make_arg = $self->make_x_arg("make");
7096         $system = sprintf("%s%s",
7097                           $system,
7098                           $make_arg ? " $make_arg" : "",
7099                          );
7100     }
7101     if (my $env = $self->prefs->{make}{env}) { # overriding the local
7102                                                # ENV of PL, not the
7103                                                # outer ENV, but
7104                                                # unlikely to be a risk
7105         for my $e (keys %$env) {
7106             $ENV{$e} = $env->{$e};
7107         }
7108     }
7109     my $expect_model = $self->_prefs_with_expect("make");
7110     my $want_expect = 0;
7111     if ( $expect_model && @{$expect_model->{talk}} ) {
7112         my $can_expect = $CPAN::META->has_inst("Expect");
7113         if ($can_expect) {
7114             $want_expect = 1;
7115         } else {
7116             $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
7117                                     "system()\n");
7118         }
7119     }
7120     my $system_ok;
7121     if ($want_expect) {
7122         $system_ok = $self->_run_via_expect($system,$expect_model) == 0;
7123     } else {
7124         $system_ok = system($system) == 0;
7125     }
7126     $self->introduce_myself;
7127     if ( $system_ok ) {
7128          $CPAN::Frontend->myprint("  $system -- OK\n");
7129          $self->{make} = CPAN::Distrostatus->new("YES");
7130     } else {
7131          $self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
7132          $self->{make} = CPAN::Distrostatus->new("NO");
7133          $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
7134     }
7135     $self->store_persistent_state;
7136 }
7137
7138 # CPAN::Distribution::_run_via_expect
7139 sub _run_via_expect {
7140     my($self,$system,$expect_model) = @_;
7141     CPAN->debug("system[$system]expect_model[$expect_model]") if $CPAN::DEBUG;
7142     if ($CPAN::META->has_inst("Expect")) {
7143         my $expo = Expect->new;  # expo Expect object;
7144         $expo->spawn($system);
7145         $expect_model->{mode} ||= "deterministic";
7146         if ($expect_model->{mode} eq "deterministic") {
7147             return $self->_run_via_expect_deterministic($expo,$expect_model);
7148         } elsif ($expect_model->{mode} eq "anyorder") {
7149             return $self->_run_via_expect_anyorder($expo,$expect_model);
7150         } else {
7151             die "Panic: Illegal expect mode: $expect_model->{mode}";
7152         }
7153     } else {
7154         $CPAN::Frontend->mywarn("Expect not installed, falling back to system()\n");
7155         return system($system);
7156     }
7157 }
7158
7159 sub _run_via_expect_anyorder {
7160     my($self,$expo,$expect_model) = @_;
7161     my $timeout = $expect_model->{timeout} || 5;
7162     my @expectacopy = @{$expect_model->{talk}}; # we trash it!
7163     my $but = "";
7164   EXPECT: while () {
7165         my($eof,$ran_into_timeout);
7166         my @match = $expo->expect($timeout,
7167                                   [ eof => sub {
7168                                         $eof++;
7169                                     } ],
7170                                   [ timeout => sub {
7171                                         $ran_into_timeout++;
7172                                     } ],
7173                                   -re => eval"qr{.}",
7174                                  );
7175         if ($match[2]) {
7176             $but .= $match[2];
7177         }
7178         $but .= $expo->clear_accum;
7179         if ($eof) {
7180             $expo->soft_close;
7181             return $expo->exitstatus();
7182         } elsif ($ran_into_timeout) {
7183             # warn "DEBUG: they are asking a question, but[$but]";
7184             for (my $i = 0; $i <= $#expectacopy; $i+=2) {
7185                 my($next,$send) = @expectacopy[$i,$i+1];
7186                 my $regex = eval "qr{$next}";
7187                 # warn "DEBUG: will compare with regex[$regex].";
7188                 if ($but =~ /$regex/) {
7189                     # warn "DEBUG: will send send[$send]";
7190                     $expo->send($send);
7191                     splice @expectacopy, $i, 2; # never allow reusing an QA pair
7192                     next EXPECT;
7193                 }
7194             }
7195             my $why = "could not answer a question during the dialog";
7196             $CPAN::Frontend->mywarn("Failing: $why\n");
7197             $self->{writemakefile} =
7198                 CPAN::Distrostatus->new("NO $why");
7199             return;
7200         }
7201     }
7202 }
7203
7204 sub _run_via_expect_deterministic {
7205     my($self,$expo,$expect_model) = @_;
7206     my $ran_into_timeout;
7207     my $timeout = $expect_model->{timeout} || 15; # currently unsettable
7208     my $expecta = $expect_model->{talk};
7209   EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) {
7210         my($re,$send) = @$expecta[$i,$i+1];
7211         CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG;
7212         my $regex = eval "qr{$re}";
7213         $expo->expect($timeout,
7214                       [ eof => sub {
7215                             my $but = $expo->clear_accum;
7216                             $CPAN::Frontend->mywarn("EOF (maybe harmless)
7217 expected[$regex]\nbut[$but]\n\n");
7218                             last EXPECT;
7219                         } ],
7220                       [ timeout => sub {
7221                             my $but = $expo->clear_accum;
7222                             $CPAN::Frontend->mywarn("TIMEOUT
7223 expected[$regex]\nbut[$but]\n\n");
7224                             $ran_into_timeout++;
7225                         } ],
7226                       -re => $regex);
7227         if ($ran_into_timeout){
7228             # note that the caller expects 0 for success
7229             $self->{writemakefile} =
7230                 CPAN::Distrostatus->new("NO timeout during expect dialog");
7231             return;
7232         }
7233         $expo->send($send);
7234     }
7235     $expo->soft_close;
7236     return $expo->exitstatus();
7237 }
7238
7239 #-> CPAN::Distribution::_validate_distropref
7240 sub _validate_distropref {
7241     my($self,@args) = @_;
7242     if (
7243         $CPAN::META->has_inst("CPAN::Kwalify")
7244         &&
7245         $CPAN::META->has_inst("Kwalify")
7246        ) {
7247         eval {CPAN::Kwalify::_validate("distroprefs",@args);};
7248         if ($@) {
7249             $CPAN::Frontend->mywarn($@);
7250         }
7251     } else {
7252         CPAN->debug("not validating '@args'") if $CPAN::DEBUG;
7253     }
7254 }
7255
7256 #-> CPAN::Distribution::_find_prefs
7257 sub _find_prefs {
7258     my($self) = @_;
7259     my $distroid = $self->pretty_id;
7260     #CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG;
7261     my $prefs_dir = $CPAN::Config->{prefs_dir};
7262     eval { File::Path::mkpath($prefs_dir); };
7263     if ($@) {
7264         $CPAN::Frontend->mydie("Cannot create directory $prefs_dir");
7265     }
7266     my $yaml_module = CPAN::_yaml_module;
7267     my @extensions;
7268     if ($CPAN::META->has_inst($yaml_module)) {
7269         push @extensions, "yml";
7270     } else {
7271         my @fallbacks;
7272         if ($CPAN::META->has_inst("Data::Dumper")) {
7273             push @extensions, "dd";
7274             push @fallbacks, "Data::Dumper";
7275         }
7276         if ($CPAN::META->has_inst("Storable")) {
7277             push @extensions, "st";
7278             push @fallbacks, "Storable";
7279         }
7280         if (@fallbacks) {
7281             local $" = " and ";
7282             unless ($self->{have_complained_about_missing_yaml}++) {
7283                 $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back ".
7284                                         "to @fallbacks to read prefs '$prefs_dir'\n");
7285             }
7286         } else {
7287             unless ($self->{have_complained_about_missing_yaml}++) {
7288                 $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot ".
7289                                         "read prefs '$prefs_dir'\n");
7290             }
7291         }
7292     }
7293     if (@extensions) {
7294         my $dh = DirHandle->new($prefs_dir)
7295             or die Carp::croak("Couldn't open '$prefs_dir': $!");
7296       DIRENT: for (sort $dh->read) {
7297             next if $_ eq "." || $_ eq "..";
7298             my $exte = join "|", @extensions;
7299             next unless /\.($exte)$/;
7300             my $thisexte = $1;
7301             my $abs = File::Spec->catfile($prefs_dir, $_);
7302             if (-f $abs) {
7303                 #CPAN->debug(sprintf "abs[%s]", $abs) if $CPAN::DEBUG;
7304                 my @distropref;
7305                 if ($thisexte eq "yml") {
7306                     # need no eval because if we have no YAML we do not try to read *.yml
7307                     #CPAN->debug(sprintf "before yaml load abs[%s]", $abs) if $CPAN::DEBUG;
7308                     @distropref = @{CPAN->_yaml_loadfile($abs)};
7309                     #CPAN->debug(sprintf "after yaml load abs[%s]", $abs) if $CPAN::DEBUG;
7310                 } elsif ($thisexte eq "dd") {
7311                     package CPAN::Eval;
7312                     no strict;
7313                     open FH, "<$abs" or $CPAN::Frontend->mydie("Could not open '$abs': $!");
7314                     local $/;
7315                     my $eval = <FH>;
7316                     close FH;
7317                     eval $eval;
7318                     if ($@) {
7319                         $CPAN::Frontend->mydie("Error in distroprefs file $_\: $@");
7320                     }
7321                     my $i = 1;
7322                     while (${"VAR".$i}) {
7323                         push @distropref, ${"VAR".$i};
7324                         $i++;
7325                     }
7326                 } elsif ($thisexte eq "st") {
7327                     # eval because Storable is never forward compatible
7328                     eval { @distropref = @{scalar Storable::retrieve($abs)}; };
7329                     if ($@) {
7330                         $CPAN::Frontend->mywarn("Error reading distroprefs file ".
7331                                                 "$_, skipping\: $@");
7332                         $CPAN::Frontend->mysleep(4);
7333                         next DIRENT;
7334                     }
7335                 }
7336                 # $DB::single=1;
7337                 #CPAN->debug(sprintf "#distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
7338               ELEMENT: for my $y (0..$#distropref) {
7339                     my $distropref = $distropref[$y];
7340                     $self->_validate_distropref($distropref,$abs,$y);
7341                     my $match = $distropref->{match};
7342                     unless ($match) {
7343                         #CPAN->debug("no 'match' in abs[$abs], skipping") if $CPAN::DEBUG;
7344                         next ELEMENT;
7345                     }
7346                     my $ok = 1;
7347                     # do not take the order of C<keys %$match> because
7348                     # "module" is by far the slowest
7349                     my $saw_valid_subkeys = 0;
7350                     for my $sub_attribute (qw(distribution perl perlconfig module)) {
7351                         next unless exists $match->{$sub_attribute};
7352                         $saw_valid_subkeys++;
7353                         my $qr = eval "qr{$distropref->{match}{$sub_attribute}}";
7354                         if ($sub_attribute eq "module") {
7355                             my $okm = 0;
7356                             #CPAN->debug(sprintf "distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
7357                             my @modules = $self->containsmods;
7358                             #CPAN->debug(sprintf "modules[%s]", join(",",@modules)) if $CPAN::DEBUG;
7359                           MODULE: for my $module (@modules) {
7360                                 $okm ||= $module =~ /$qr/;
7361                                 last MODULE if $okm;
7362                             }
7363                             $ok &&= $okm;
7364                         } elsif ($sub_attribute eq "distribution") {
7365                             my $okd = $distroid =~ /$qr/;
7366                             $ok &&= $okd;
7367                         } elsif ($sub_attribute eq "perl") {
7368                             my $okp = $^X =~ /$qr/;
7369                             $ok &&= $okp;
7370                         } elsif ($sub_attribute eq "perlconfig") {
7371                             for my $perlconfigkey (keys %{$match->{perlconfig}}) {
7372                                 my $perlconfigval = $match->{perlconfig}->{$perlconfigkey};
7373                                 # XXX should probably warn if Config does not exist
7374                                 my $okpc = $Config::Config{$perlconfigkey} =~ /$perlconfigval/;
7375                                 $ok &&= $okpc;
7376                                 last if $ok == 0;
7377                             }
7378                         } else {
7379                             $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ".
7380                                                    "unknown sub_attribut '$sub_attribute'. ".
7381                                                    "Please ".
7382                                                    "remove, cannot continue.");
7383                         }
7384                         last if $ok == 0; # short circuit
7385                     }
7386                     unless ($saw_valid_subkeys) {
7387                         $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ".
7388                                                "missing match/* subattribute. ".
7389                                                "Please ".
7390                                                "remove, cannot continue.");
7391                     }
7392                     #CPAN->debug(sprintf "ok[%d]", $ok) if $CPAN::DEBUG;
7393                     if ($ok) {
7394                         return {
7395                                 prefs => $distropref,
7396                                 prefs_file => $abs,
7397                                 prefs_file_doc => $y,
7398                                };
7399                     }
7400
7401                 }
7402             }
7403         }
7404         $dh->close;
7405     }
7406     return;
7407 }
7408
7409 # CPAN::Distribution::prefs
7410 sub prefs {
7411     my($self) = @_;
7412     if (exists $self->{negative_prefs_cache}
7413         &&
7414         $self->{negative_prefs_cache} != $CPAN::CurrentCommandId
7415        ) {
7416         delete $self->{negative_prefs_cache};
7417         delete $self->{prefs};
7418     }
7419     if (exists $self->{prefs}) {
7420         return $self->{prefs}; # XXX comment out during debugging
7421     }
7422     if ($CPAN::Config->{prefs_dir}) {
7423         CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG;
7424         my $prefs = $self->_find_prefs();
7425         $prefs ||= ""; # avoid warning next line
7426         CPAN->debug("prefs[$prefs]") if $CPAN::DEBUG;
7427         if ($prefs) {
7428             for my $x (qw(prefs prefs_file prefs_file_doc)) {
7429                 $self->{$x} = $prefs->{$x};
7430             }
7431             my $bs = sprintf(
7432                              "%s[%s]",
7433                              File::Basename::basename($self->{prefs_file}),
7434                              $self->{prefs_file_doc},
7435                             );
7436             my $filler1 = "_" x 22;
7437             my $filler2 = int(66 - length($bs))/2;
7438             $filler2 = 0 if $filler2 < 0;
7439             $filler2 = " " x $filler2;
7440             $CPAN::Frontend->myprint("
7441 $filler1 D i s t r o P r e f s $filler1
7442 $filler2 $bs $filler2
7443 ");
7444             $CPAN::Frontend->mysleep(1);
7445             return $self->{prefs};
7446         }
7447     }
7448     $self->{negative_prefs_cache} = $CPAN::CurrentCommandId;
7449     return $self->{prefs} = +{};
7450 }
7451
7452 # CPAN::Distribution::make_x_arg
7453 sub make_x_arg {
7454     my($self, $whixh) = @_;
7455     my $make_x_arg;
7456     my $prefs = $self->prefs;
7457     if (
7458         $prefs
7459         && exists $prefs->{$whixh}
7460         && exists $prefs->{$whixh}{args}
7461         && $prefs->{$whixh}{args}
7462        ) {
7463         $make_x_arg = join(" ",
7464                            map {CPAN::HandleConfig
7465                                  ->safe_quote($_)} @{$prefs->{$whixh}{args}},
7466                           );
7467     }
7468     my $what = sprintf "make%s_arg", $whixh eq "make" ? "" : $whixh;
7469     $make_x_arg ||= $CPAN::Config->{$what};
7470     return $make_x_arg;
7471 }
7472
7473 # CPAN::Distribution::_make_command
7474 sub _make_command {
7475     my ($self) = @_;
7476     if ($self) {
7477         return
7478             CPAN::HandleConfig
7479                 ->safe_quote(
7480                              CPAN::HandleConfig->prefs_lookup($self,
7481                                                               q{make})
7482                              || $Config::Config{make}
7483                              || 'make'
7484                             );
7485     } else {
7486         # Old style call, without object. Deprecated
7487         Carp::confess("CPAN::_make_command() used as function. Don't Do That.");
7488         return
7489           safe_quote(undef,
7490                      CPAN::HandleConfig->prefs_lookup($self,q{make})
7491                      || $CPAN::Config->{make}
7492                      || $Config::Config{make}
7493                      || 'make');
7494     }
7495 }
7496
7497 #-> sub CPAN::Distribution::follow_prereqs ;
7498 sub follow_prereqs {
7499     my($self) = shift;
7500     my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
7501     return unless @prereq_tuples;
7502     my @prereq = map { $_->[0] } @prereq_tuples;
7503     my $pretty_id = $self->pretty_id;
7504     my %map = (
7505                b => "build_requires",
7506                r => "requires",
7507                c => "commandline",
7508               );
7509     my($filler1,$filler2,$filler3,$filler4);
7510     # $DB::single=1;
7511     my $unsat = "Unsatisfied dependencies detected during";
7512     my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id);
7513     {
7514         my $r = int(($w - length($unsat))/2);
7515         my $l = $w - length($unsat) - $r;
7516         $filler1 = "-"x4 . " "x$l;
7517         $filler2 = " "x$r . "-"x4 . "\n";
7518     }
7519     {
7520         my $r = int(($w - length($pretty_id))/2);
7521         my $l = $w - length($pretty_id) - $r;
7522         $filler3 = "-"x4 . " "x$l;
7523         $filler4 = " "x$r . "-"x4 . "\n";
7524     }
7525     $CPAN::Frontend->
7526         myprint("$filler1 $unsat $filler2".
7527                 "$filler3 $pretty_id $filler4".
7528                 join("", map {"    $_->[0] \[$map{$_->[1]}]\n"} @prereq_tuples),
7529                );
7530     my $follow = 0;
7531     if ($CPAN::Config->{prerequisites_policy} eq "follow") {
7532         $follow = 1;
7533     } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
7534         my $answer = CPAN::Shell::colorable_makemaker_prompt(
7535 "Shall I follow them and prepend them to the queue
7536 of modules we are processing right now?", "yes");
7537         $follow = $answer =~ /^\s*y/i;
7538     } else {
7539         local($") = ", ";
7540         $CPAN::Frontend->
7541             myprint("  Ignoring dependencies on modules @prereq\n");
7542     }
7543     if ($follow) {
7544         my $id = $self->id;
7545         # color them as dirty
7546         for my $p (@prereq) {
7547             # warn "calling color_cmd_tmps(0,1)";
7548             my $any = CPAN::Shell->expandany($p);
7549             if ($any) {
7550                 $any->color_cmd_tmps(0,2);
7551             } else {
7552                 $CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$p'\n");
7553                 $CPAN::Frontend->mysleep(2);
7554             }
7555         }
7556         # queue them and re-queue yourself
7557         CPAN::Queue->jumpqueue([$id,$self->{reqtype}],
7558                                reverse @prereq_tuples);
7559         $self->{later} = "Delayed until after prerequisites";
7560         return 1; # signal success to the queuerunner
7561     }
7562 }
7563
7564 #-> sub CPAN::Distribution::unsat_prereq ;
7565 # return ([Foo=>1],[Bar=>1.2]) for normal modules
7566 # return ([perl=>5.008]) if we need a newer perl than we are running under
7567 sub unsat_prereq {
7568     my($self) = @_;
7569     my $prereq_pm = $self->prereq_pm or return;
7570     my(@need);
7571     my %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}});
7572     my @merged = %merged;
7573     CPAN->debug("all merged_prereqs[@merged]") if $CPAN::DEBUG;
7574   NEED: while (my($need_module, $need_version) = each %merged) {
7575         my($available_version,$available_file,$nmo);
7576         if ($need_module eq "perl") {
7577             $available_version = $];
7578             $available_file = $^X;
7579         } else {
7580             $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
7581             next if $nmo->uptodate;
7582             $available_file = $nmo->available_file;
7583
7584             # if they have not specified a version, we accept any installed one
7585             if (defined $available_file
7586                 and ( # a few quick shortcurcuits
7587                      not defined $need_version
7588                      or $need_version eq '0'    # "==" would trigger warning when not numeric
7589                      or $need_version eq "undef"
7590                     )) {
7591                 next NEED;
7592             }
7593
7594             $available_version = $nmo->available_version;
7595         }
7596
7597         # We only want to install prereqs if either they're not installed
7598         # or if the installed version is too old. We cannot omit this
7599         # check, because if 'force' is in effect, nobody else will check.
7600         if (defined $available_file) {
7601             my(@all_requirements) = split /\s*,\s*/, $need_version;
7602             local($^W) = 0;
7603             my $ok = 0;
7604           RQ: for my $rq (@all_requirements) {
7605                 if ($rq =~ s|>=\s*||) {
7606                 } elsif ($rq =~ s|>\s*||) {
7607                     # 2005-12: one user
7608                     if (CPAN::Version->vgt($available_version,$rq)){
7609                         $ok++;
7610                     }
7611                     next RQ;
7612                 } elsif ($rq =~ s|!=\s*||) {
7613                     # 2005-12: no user
7614                     if (CPAN::Version->vcmp($available_version,$rq)){
7615                         $ok++;
7616                         next RQ;
7617                     } else {
7618                         last RQ;
7619                     }
7620                 } elsif ($rq =~ m|<=?\s*|) {
7621                     # 2005-12: no user
7622                     $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n");
7623                     $ok++;
7624                     next RQ;
7625                 }
7626                 if (! CPAN::Version->vgt($rq, $available_version)){
7627                     $ok++;
7628                 }
7629                 CPAN->debug(sprintf("need_module[%s]available_file[%s]".
7630                                     "available_version[%s]rq[%s]ok[%d]",
7631                                     $need_module,
7632                                     $available_file,
7633                                     $available_version,
7634                                     CPAN::Version->readable($rq),
7635                                     $ok,
7636                                    )) if $CPAN::DEBUG;
7637             }
7638             next NEED if $ok == @all_requirements;
7639         }
7640
7641         if ($need_module eq "perl") {
7642             return ["perl", $need_version];
7643         }
7644         if ($self->{sponsored_mods}{$need_module}++){
7645             # We have already sponsored it and for some reason it's still
7646             # not available. So we do ... what??
7647
7648             # if we push it again, we have a potential infinite loop
7649
7650             # The following "next" was a very problematic construct.
7651             # It helped a lot but broke some day and must be replaced.
7652
7653             # We must be able to deal with modules that come again and
7654             # again as a prereq and have themselves prereqs and the
7655             # queue becomes long but finally we would find the correct
7656             # order. The RecursiveDependency check should trigger a
7657             # die when it's becoming too weird. Unfortunately removing
7658             # this next breaks many other things.
7659
7660             # The bug that brought this up is described in Todo under
7661             # "5.8.9 cannot install Compress::Zlib"
7662
7663             # next; # this is the next that must go away
7664
7665             # The following "next NEED" are fine and the error message
7666             # explains well what is going on. For example when the DBI
7667             # fails and consequently DBD::SQLite fails and now we are
7668             # processing CPAN::SQLite. Then we must have a "next" for
7669             # DBD::SQLite. How can we get it and how can we identify
7670             # all other cases we must identify?
7671
7672             my $do = $nmo->distribution;
7673             next NEED unless $do; # not on CPAN
7674           NOSAYER: for my $nosayer (
7675                                     "unwrapped",
7676                                     "writemakefile",
7677                                     "signature_verify",
7678                                     "make",
7679                                     "make_test",
7680                                     "install",
7681                                     "make_clean",
7682                                    ) {
7683                 if (
7684                     $do->{$nosayer}
7685                     &&(UNIVERSAL::can($do->{$nosayer},"failed") ?
7686                        $do->{$nosayer}->failed :
7687                        $do->{$nosayer} =~ /^NO/)
7688                    ) {
7689                     if ($nosayer eq "make_test"
7690                         &&
7691                         $do->{make_test}{COMMANDID} != $CPAN::CurrentCommandId
7692                        ) {
7693                         next NOSAYER;
7694                     }
7695                     $CPAN::Frontend->mywarn("Warning: Prerequisite ".
7696                                             "'$need_module => $need_version' ".
7697                                             "for '$self->{ID}' failed when ".
7698                                             "processing '$do->{ID}' with ".
7699                                             "'$nosayer => $do->{$nosayer}'. Continuing, ".
7700                                             "but chances to succeed are limited.\n"
7701                                            );
7702                     next NEED;
7703                 }
7704             }
7705         }
7706         my $needed_as = exists $prereq_pm->{requires}{$need_module} ? "r" : "b";
7707         push @need, [$need_module,$needed_as];
7708     }
7709     my @unfolded = map { "[".join(",",@$_)."]" } @need;
7710     CPAN->debug("returning from unsat_prereq[@unfolded]") if $CPAN::DEBUG;
7711     @need;
7712 }
7713
7714 #-> sub CPAN::Distribution::read_yaml ;
7715 sub read_yaml {
7716     my($self) = @_;
7717     return $self->{yaml_content} if exists $self->{yaml_content};
7718     my $build_dir = $self->{build_dir};
7719     my $yaml = File::Spec->catfile($build_dir,"META.yml");
7720     $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
7721     return unless -f $yaml;
7722     eval { $self->{yaml_content} = CPAN->_yaml_loadfile($yaml)->[0]; };
7723     if ($@) {
7724         $CPAN::Frontend->mywarn("Could not read ".
7725                                 "'$yaml'. Falling back to other ".
7726                                 "methods to determine prerequisites\n");
7727         return $self->{yaml_content} = undef; # if we die, then we
7728                                               # cannot read YAML's own
7729                                               # META.yml
7730     }
7731     # not "authoritative"
7732     if (not exists $self->{yaml_content}{dynamic_config}
7733         or $self->{yaml_content}{dynamic_config}
7734        ) {
7735         $self->{yaml_content} = undef;
7736     }
7737     $self->debug(sprintf "yaml_content[%s]", $self->{yaml_content} || "UNDEF")
7738         if $CPAN::DEBUG;
7739     return $self->{yaml_content};
7740 }
7741
7742 #-> sub CPAN::Distribution::prereq_pm ;
7743 sub prereq_pm {
7744     my($self) = @_;
7745     $self->{prereq_pm_detected} ||= 0;
7746     CPAN->debug("ID[$self->{ID}]prereq_pm_detected[$self->{prereq_pm_detected}]") if $CPAN::DEBUG;
7747     return $self->{prereq_pm} if $self->{prereq_pm_detected};
7748     return unless $self->{writemakefile}  # no need to have succeeded
7749                                           # but we must have run it
7750         || $self->{modulebuild};
7751     CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
7752                 $self->{writemakefile}||"",
7753                 $self->{modulebuild}||"",
7754                ) if $CPAN::DEBUG;
7755     my($req,$breq);
7756     if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
7757         $req =  $yaml->{requires} || {};
7758         $breq =  $yaml->{build_requires} || {};
7759         undef $req unless ref $req eq "HASH" && %$req;
7760         if ($req) {
7761             if ($yaml->{generated_by} &&
7762                 $yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
7763                 my $eummv = do { local $^W = 0; $1+0; };
7764                 if ($eummv < 6.2501) {
7765                     # thanks to Slaven for digging that out: MM before
7766                     # that could be wrong because it could reflect a
7767                     # previous release
7768                     undef $req;
7769                 }
7770             }
7771             my $areq;
7772             my $do_replace;
7773             while (my($k,$v) = each %{$req||{}}) {
7774                 if ($v =~ /\d/) {
7775                     $areq->{$k} = $v;
7776                 } elsif ($k =~ /[A-Za-z]/ &&
7777                          $v =~ /[A-Za-z]/ &&
7778                          $CPAN::META->exists("Module",$v)
7779                         ) {
7780                     $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
7781                                             "requires hash: $k => $v; I'll take both ".
7782                                             "key and value as a module name\n");
7783                     $CPAN::Frontend->mysleep(1);
7784                     $areq->{$k} = 0;
7785                     $areq->{$v} = 0;
7786                     $do_replace++;
7787                 }
7788             }
7789             $req = $areq if $do_replace;
7790         }
7791     }
7792     unless ($req || $breq) {
7793         my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
7794         my $makefile = File::Spec->catfile($build_dir,"Makefile");
7795         my $fh;
7796         if (-f $makefile
7797             and
7798             $fh = FileHandle->new("<$makefile\0")) {
7799             CPAN->debug("Getting prereq from Makefile") if $CPAN::DEBUG;
7800             local($/) = "\n";
7801             while (<$fh>) {
7802                 last if /MakeMaker post_initialize section/;
7803                 my($p) = m{^[\#]
7804                            \s+PREREQ_PM\s+=>\s+(.+)
7805                        }x;
7806                 next unless $p;
7807                 # warn "Found prereq expr[$p]";
7808
7809                 #  Regexp modified by A.Speer to remember actual version of file
7810                 #  PREREQ_PM hash key wants, then add to
7811                 while ( $p =~ m/(?:\s)([\w\:]+)=>(q\[.*?\]|undef),?/g ){
7812                     # In case a prereq is mentioned twice, complain.
7813                     if ( defined $req->{$1} ) {
7814                         warn "Warning: PREREQ_PM mentions $1 more than once, ".
7815                             "last mention wins";
7816                     }
7817                     my($m,$n) = ($1,$2);
7818                     if ($n =~ /^q\[(.*?)\]$/) {
7819                         $n = $1;
7820                     }
7821                     $req->{$m} = $n;
7822                 }
7823                 last;
7824             }
7825         }
7826     }
7827     unless ($req || $breq) {
7828         my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
7829         my $buildfile = File::Spec->catfile($build_dir,"Build");
7830         if (-f $buildfile) {
7831             CPAN->debug("Found '$buildfile'") if $CPAN::DEBUG;
7832             my $build_prereqs = File::Spec->catfile($build_dir,"_build","prereqs");
7833             if (-f $build_prereqs) {
7834                 CPAN->debug("Getting prerequisites from '$build_prereqs'") if $CPAN::DEBUG;
7835                 my $content = do { local *FH;
7836                                    open FH, $build_prereqs
7837                                        or $CPAN::Frontend->mydie("Could not open ".
7838                                                                  "'$build_prereqs': $!");
7839                                    local $/;
7840                                    <FH>;
7841                                };
7842                 my $bphash = eval $content;
7843                 if ($@) {
7844                 } else {
7845                     $req  = $bphash->{requires} || +{};
7846                     $breq = $bphash->{build_requires} || +{};
7847                 }
7848             }
7849         }
7850     }
7851     if (-f "Build.PL"
7852         && ! -f "Makefile.PL"
7853         && ! exists $req->{"Module::Build"}
7854         && ! $CPAN::META->has_inst("Module::Build")) {
7855         $CPAN::Frontend->mywarn("  Warning: CPAN.pm discovered Module::Build as ".
7856                                 "undeclared prerequisite.\n".
7857                                 "  Adding it now as such.\n"
7858                                );
7859         $CPAN::Frontend->mysleep(5);
7860         $req->{"Module::Build"} = 0;
7861         delete $self->{writemakefile};
7862     }
7863     if ($req || $breq) {
7864         $self->{prereq_pm_detected}++;
7865         return $self->{prereq_pm} = { requires => $req, build_requires => $breq };
7866     }
7867 }
7868
7869 #-> sub CPAN::Distribution::test ;
7870 sub test {
7871     my($self) = @_;
7872     if (my $goto = $self->prefs->{goto}) {
7873         return $self->goto($goto);
7874     }
7875     $self->make;
7876     if ($CPAN::Signal){
7877       delete $self->{force_update};
7878       return;
7879     }
7880     # warn "XDEBUG: checking for notest: $self->{notest} $self";
7881     if ($self->{notest}) {
7882         $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
7883         return 1;
7884     }
7885
7886     my $make = $self->{modulebuild} ? "Build" : "make";
7887
7888     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
7889                            ? $ENV{PERL5LIB}
7890                            : ($ENV{PERLLIB} || "");
7891
7892     $CPAN::META->set_perl5lib;
7893     local $ENV{MAKEFLAGS}; # protect us from outer make calls
7894
7895     $CPAN::Frontend->myprint("Running $make test\n");
7896
7897 #    if (my @prereq = $self->unsat_prereq){
7898 #        if ( $CPAN::DEBUG ) {
7899 #            require Data::Dumper;
7900 #            CPAN->debug(sprintf "unsat_prereq[%s]", Data::Dumper::Dumper(\@prereq));
7901 #        }
7902 #        unless ($prereq[0][0] eq "perl") {
7903 #            return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
7904 #        }
7905 #    }
7906
7907   EXCUSE: {
7908         my @e;
7909         unless (exists $self->{make} or exists $self->{later}) {
7910             push @e,
7911                 "Make had some problems, won't test";
7912         }
7913
7914         exists $self->{make} and
7915             (
7916              UNIVERSAL::can($self->{make},"failed") ?
7917              $self->{make}->failed :
7918              $self->{make} =~ /^NO/
7919             ) and push @e, "Can't test without successful make";
7920
7921         $self->{badtestcnt} ||= 0;
7922         if ($self->{badtestcnt} > 0) {
7923             require Data::Dumper;
7924             CPAN->debug(sprintf "NOREPEAT[%s]", Data::Dumper::Dumper($self)) if $CPAN::DEBUG;
7925             push @e, "Won't repeat unsuccessful test during this command";
7926         }
7927
7928         exists $self->{later} and length($self->{later}) and
7929             push @e, $self->{later};
7930
7931         if (exists $self->{build_dir}) {
7932             if ($CPAN::META->{is_tested}{$self->{build_dir}}
7933                 &&
7934                 exists $self->{make_test}
7935                 &&
7936                 !(
7937                   UNIVERSAL::can($self->{make_test},"failed") ?
7938                   $self->{make_test}->failed :
7939                   $self->{make_test} =~ /^NO/
7940                  )
7941                ) {
7942                 push @e, "Has already been tested successfully";
7943             }
7944         } elsif (!@e) {
7945             push @e, "Has no own directory";
7946         }
7947         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
7948         unless (chdir $self->{build_dir}) {
7949             push @e, "Couldn't chdir to '$self->{build_dir}': $!";
7950         }
7951         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
7952     }
7953     $self->debug("Changed directory to $self->{build_dir}")
7954         if $CPAN::DEBUG;
7955
7956     if ($^O eq 'MacOS') {
7957         Mac::BuildTools::make_test($self);
7958         return;
7959     }
7960
7961     if ($self->{modulebuild}) {
7962         my $v = CPAN::Shell->expand("Module","Test::Harness")->inst_version;
7963         if (CPAN::Version->vlt($v,2.62)) {
7964             $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
7965   '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n});
7966             $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old");
7967             return;
7968         }
7969     }
7970
7971     my $system;
7972     if (my $commandline = $self->prefs->{test}{commandline}) {
7973         $system = $commandline;
7974         $ENV{PERL} = $^X;
7975     } elsif ($self->{modulebuild}) {
7976         $system = sprintf "%s test", $self->_build_command();
7977     } else {
7978         $system = join " ", $self->_make_command(), "test";
7979     }
7980     my $make_test_arg = $self->make_x_arg("test");
7981     $system = sprintf("%s%s",
7982                       $system,
7983                       $make_test_arg ? " $make_test_arg" : "",
7984                      );
7985     my($tests_ok);
7986     my %env;
7987     while (my($k,$v) = each %ENV) {
7988         next unless defined $v;
7989         $env{$k} = $v;
7990     }
7991     local %ENV = %env;
7992     if (my $env = $self->prefs->{test}{env}) {
7993         for my $e (keys %$env) {
7994             $ENV{$e} = $env->{$e};
7995         }
7996     }
7997     my $expect_model = $self->_prefs_with_expect("test");
7998     my $want_expect = 0;
7999     if ( $expect_model && @{$expect_model->{talk}} ) {
8000         my $can_expect = $CPAN::META->has_inst("Expect");
8001         if ($can_expect) {
8002             $want_expect = 1;
8003         } else {
8004             $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
8005                                     "testing without\n");
8006         }
8007     }
8008     my $test_report = CPAN::HandleConfig->prefs_lookup($self,
8009                                                        q{test_report});
8010     my $want_report;
8011     if ($test_report) {
8012         my $can_report = $CPAN::META->has_inst("CPAN::Reporter");
8013         if ($can_report) {
8014             $want_report = 1;
8015         } else {
8016             $CPAN::Frontend->mywarn("CPAN::Reporter not installed, falling back to ".
8017                                     "testing without\n");
8018         }
8019     }
8020     my $ready_to_report = $want_report;
8021     if ($ready_to_report
8022         && (
8023             substr($self->id,-1,1) eq "."
8024             ||
8025             $self->author->id eq "LOCAL"
8026            )
8027        ) {
8028         $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
8029                                 "for local directories\n");
8030         $ready_to_report = 0;
8031     }
8032     if ($ready_to_report
8033         &&
8034         $self->prefs->{patches}
8035         &&
8036         @{$self->prefs->{patches}}
8037         &&
8038         $self->{patched}
8039        ) {
8040         $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
8041                                 "when the source has been patched\n");
8042         $ready_to_report = 0;
8043     }
8044     if ($want_expect) {
8045         if ($ready_to_report) {
8046             $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ".
8047                                     "not supported when distroprefs specify ".
8048                                     "an interactive test\n");
8049         }
8050         $tests_ok = $self->_run_via_expect($system,$expect_model) == 0;
8051     } elsif ( $ready_to_report ) {
8052         $tests_ok = CPAN::Reporter::test($self, $system);
8053     } else {
8054         $tests_ok = system($system) == 0;
8055     }
8056     $self->introduce_myself;
8057     if ( $tests_ok ) {
8058         {
8059             my @prereq;
8060
8061             # local $CPAN::DEBUG = 16; # Distribution
8062             for my $m (keys %{$self->{sponsored_mods}}) {
8063                 my $m_obj = CPAN::Shell->expand("Module",$m) or next;
8064                 # XXX we need available_version which reflects
8065                 # $ENV{PERL5LIB} so that already tested but not yet
8066                 # installed modules are counted.
8067                 my $available_version = $m_obj->available_version;
8068                 my $available_file = $m_obj->available_file;
8069                 if ($available_version &&
8070                     !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m})
8071                    ) {
8072                     CPAN->debug("m[$m] good enough available_version[$available_version]")
8073                         if $CPAN::DEBUG;
8074                 } elsif ($available_file
8075                          && (
8076                              !$self->{prereq_pm}{$m}
8077                              ||
8078                              $self->{prereq_pm}{$m} == 0
8079                             )
8080                         ) {
8081                     # lex Class::Accessor::Chained::Fast which has no $VERSION
8082                     CPAN->debug("m[$m] have available_file[$available_file]")
8083                         if $CPAN::DEBUG;
8084                 } else {
8085                     push @prereq, $m;
8086                 }
8087             }
8088             if (@prereq){
8089                 my $cnt = @prereq;
8090                 my $which = join ",", @prereq;
8091                 my $but = $cnt == 1 ? "one dependency not OK ($which)" :
8092                     "$cnt dependencies missing ($which)";
8093                 $CPAN::Frontend->mywarn("Tests succeeded but $but\n");
8094                 $self->{make_test} = CPAN::Distrostatus->new("NO $but");
8095                 $self->store_persistent_state;
8096                 return;
8097             }
8098         }
8099
8100         $CPAN::Frontend->myprint("  $system -- OK\n");
8101         $self->{make_test} = CPAN::Distrostatus->new("YES");
8102         $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
8103         # probably impossible to need the next line because badtestcnt
8104         # has a lifespan of one command
8105         delete $self->{badtestcnt};
8106     } else {
8107         $self->{make_test} = CPAN::Distrostatus->new("NO");
8108         $self->{badtestcnt}++;
8109         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
8110     }
8111     $self->store_persistent_state;
8112 }
8113
8114 sub _prefs_with_expect {
8115     my($self,$where) = @_;
8116     return unless my $prefs = $self->prefs;
8117     return unless my $where_prefs = $prefs->{$where};
8118     if ($where_prefs->{expect}) {
8119         return {
8120                 mode => "deterministic",
8121                 timeout => 15,
8122                 talk => $where_prefs->{expect},
8123                };
8124     } elsif ($where_prefs->{"eexpect"}) {
8125         return $where_prefs->{"eexpect"};
8126     }
8127     return;
8128 }
8129
8130 #-> sub CPAN::Distribution::clean ;
8131 sub clean {
8132     my($self) = @_;
8133     my $make = $self->{modulebuild} ? "Build" : "make";
8134     $CPAN::Frontend->myprint("Running $make clean\n");
8135     unless (exists $self->{archived}) {
8136         $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped".
8137                                 "/untarred, nothing done\n");
8138         return 1;
8139     }
8140     unless (exists $self->{build_dir}) {
8141         $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
8142         return 1;
8143     }
8144     if (exists $self->{writemakefile}
8145         and $self->{writemakefile}->failed
8146        ) {
8147         $CPAN::Frontend->mywarn("No Makefile, don't know how to 'make clean'\n");
8148         return 1;
8149     }
8150   EXCUSE: {
8151         my @e;
8152         exists $self->{make_clean} and $self->{make_clean} eq "YES" and
8153             push @e, "make clean already called once";
8154         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
8155     }
8156     chdir $self->{build_dir} or
8157         Carp::confess("Couldn't chdir to $self->{build_dir}: $!");
8158     $self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG;
8159
8160     if ($^O eq 'MacOS') {
8161         Mac::BuildTools::make_clean($self);
8162         return;
8163     }
8164
8165     my $system;
8166     if ($self->{modulebuild}) {
8167         unless (-f "Build") {
8168             my $cwd = CPAN::anycwd();
8169             $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
8170                                     " in cwd[$cwd]. Danger, Will Robinson!");
8171             $CPAN::Frontend->mysleep(5);
8172         }
8173         $system = sprintf "%s clean", $self->_build_command();
8174     } else {
8175         $system  = join " ", $self->_make_command(), "clean";
8176     }
8177     my $system_ok = system($system) == 0;
8178     $self->introduce_myself;
8179     if ( $system_ok ) {
8180       $CPAN::Frontend->myprint("  $system -- OK\n");
8181
8182       # $self->force;
8183
8184       # Jost Krieger pointed out that this "force" was wrong because
8185       # it has the effect that the next "install" on this distribution
8186       # will untar everything again. Instead we should bring the
8187       # object's state back to where it is after untarring.
8188
8189       for my $k (qw(
8190                     force_update
8191                     install
8192                     writemakefile
8193                     make
8194                     make_test
8195                    )) {
8196           delete $self->{$k};
8197       }
8198       $self->{make_clean} = CPAN::Distrostatus->new("YES");
8199
8200     } else {
8201       # Hmmm, what to do if make clean failed?
8202
8203       $self->{make_clean} = CPAN::Distrostatus->new("NO");
8204       $CPAN::Frontend->mywarn(qq{  $system -- NOT OK\n});
8205
8206       # 2006-02-27: seems silly to me to force a make now
8207       # $self->force("make"); # so that this directory won't be used again
8208
8209     }
8210     $self->store_persistent_state;
8211 }
8212
8213 #-> sub CPAN::Distribution::goto ;
8214 sub goto {
8215     my($self,$goto) = @_;
8216     $goto = $self->normalize($goto);
8217
8218     # inject into the queue
8219
8220     CPAN::Queue->delete($self->id);
8221     CPAN::Queue->jumpqueue([$goto,$self->{reqtype}]);
8222
8223     # and run where we left off
8224
8225     my($method) = (caller(1))[3];
8226     CPAN->instance("CPAN::Distribution",$goto)->$method;
8227     CPAN::Queue->delete_first($goto);
8228 }
8229
8230 #-> sub CPAN::Distribution::install ;
8231 sub install {
8232     my($self) = @_;
8233     if (my $goto = $self->prefs->{goto}) {
8234         return $self->goto($goto);
8235     }
8236     $DB::single=1;
8237     unless ($self->{badtestcnt}) {
8238         $self->test;
8239     }
8240     if ($CPAN::Signal){
8241       delete $self->{force_update};
8242       return;
8243     }
8244     my $make = $self->{modulebuild} ? "Build" : "make";
8245     $CPAN::Frontend->myprint("Running $make install\n");
8246   EXCUSE: {
8247         my @e;
8248         unless (exists $self->{make} or exists $self->{later}) {
8249             push @e,
8250                 "Make had some problems, won't install";
8251         }
8252
8253         exists $self->{make} and
8254             (
8255              UNIVERSAL::can($self->{make},"failed") ?
8256              $self->{make}->failed :
8257              $self->{make} =~ /^NO/
8258             ) and
8259                 push @e, "Make had returned bad status, install seems impossible";
8260
8261         if (exists $self->{build_dir}) {
8262         } elsif (!@e) {
8263             push @e, "Has no own directory";
8264         }
8265
8266         if (exists $self->{make_test} and
8267             (
8268              UNIVERSAL::can($self->{make_test},"failed") ?
8269              $self->{make_test}->failed :
8270              $self->{make_test} =~ /^NO/
8271             )){
8272             if ($self->{force_update}) {
8273                 $self->{make_test}->text("FAILED but failure ignored because ".
8274                                          "'force' in effect");
8275             } else {
8276                 push @e, "make test had returned bad status, ".
8277                     "won't install without force"
8278             }
8279         }
8280         if (exists $self->{install}) {
8281             if (UNIVERSAL::can($self->{install},"text") ?
8282                 $self->{install}->text eq "YES" :
8283                 $self->{install} =~ /^YES/
8284                ) {
8285                 push @e, "Already done";
8286             } else {
8287                 # comment in Todo on 2006-02-11; maybe retry?
8288                 push @e, "Already tried without success";
8289             }
8290         }
8291
8292         exists $self->{later} and length($self->{later}) and
8293             push @e, $self->{later};
8294
8295         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
8296         unless (chdir $self->{build_dir}) {
8297             push @e, "Couldn't chdir to '$self->{build_dir}': $!";
8298         }
8299         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
8300     }
8301     $self->debug("Changed directory to $self->{build_dir}")
8302         if $CPAN::DEBUG;
8303
8304     if ($^O eq 'MacOS') {
8305         Mac::BuildTools::make_install($self);
8306         return;
8307     }
8308
8309     my $system;
8310     if (my $commandline = $self->prefs->{install}{commandline}) {
8311         $system = $commandline;
8312         $ENV{PERL} = $^X;
8313     } elsif ($self->{modulebuild}) {
8314         my($mbuild_install_build_command) =
8315             exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
8316                 $CPAN::Config->{mbuild_install_build_command} ?
8317                     $CPAN::Config->{mbuild_install_build_command} :
8318                         $self->_build_command();
8319         $system = sprintf("%s install %s",
8320                           $mbuild_install_build_command,
8321                           $CPAN::Config->{mbuild_install_arg},
8322                          );
8323     } else {
8324         my($make_install_make_command) =
8325             CPAN::HandleConfig->prefs_lookup($self,
8326                                              q{make_install_make_command})
8327                   || $self->_make_command();
8328         $system = sprintf("%s install %s",
8329                           $make_install_make_command,
8330                           $CPAN::Config->{make_install_arg},
8331                          );
8332     }
8333
8334     my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 ";
8335     my $brip = CPAN::HandleConfig->prefs_lookup($self,
8336                                                 q{build_requires_install_policy});
8337     $brip ||="ask/yes";
8338     my $id = $self->id;
8339     my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command
8340     my $want_install = "yes";
8341     if ($reqtype eq "b") {
8342         if ($brip eq "no") {
8343             $want_install = "no";
8344         } elsif ($brip =~ m|^ask/(.+)|) {
8345             my $default = $1;
8346             $default = "yes" unless $default =~ /^(y|n)/i;
8347             $want_install =
8348                 CPAN::Shell::colorable_makemaker_prompt
8349                       ("$id is just needed temporarily during building or testing. ".
8350                        "Do you want to install it permanently? (Y/n)",
8351                        $default);
8352         }
8353     }
8354     unless ($want_install =~ /^y/i) {
8355         my $is_only = "is only 'build_requires'";
8356         $CPAN::Frontend->mywarn("Not installing because $is_only\n");
8357         $self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
8358         delete $self->{force_update};
8359         return;
8360     }
8361     my($pipe) = FileHandle->new("$system $stderr |");
8362     my($makeout) = "";
8363     while (<$pipe>){
8364         print $_; # intentionally NOT use Frontend->myprint because it
8365                   # looks irritating when we markup in color what we
8366                   # just pass through from an external program
8367         $makeout .= $_;
8368     }
8369     $pipe->close;
8370     my $close_ok = $? == 0;
8371     $self->introduce_myself;
8372     if ( $close_ok ) {
8373         $CPAN::Frontend->myprint("  $system -- OK\n");
8374         $CPAN::META->is_installed($self->{build_dir});
8375         $self->{install} = CPAN::Distrostatus->new("YES");
8376     } else {
8377         $self->{install} = CPAN::Distrostatus->new("NO");
8378         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
8379         my $mimc =
8380             CPAN::HandleConfig->prefs_lookup($self,
8381                                              q{make_install_make_command});
8382         if (
8383             $makeout =~ /permission/s
8384             && $> > 0
8385             && (
8386                 ! $mimc
8387                 || $mimc eq (CPAN::HandleConfig->prefs_lookup($self,
8388                                                               q{make}))
8389                )
8390            ) {
8391             $CPAN::Frontend->myprint(
8392                                      qq{----\n}.
8393                                      qq{  You may have to su }.
8394                                      qq{to root to install the package\n}.
8395                                      qq{  (Or you may want to run something like\n}.
8396                                      qq{    o conf make_install_make_command 'sudo make'\n}.
8397                                      qq{  to raise your permissions.}
8398                                     );
8399         }
8400     }
8401     delete $self->{force_update};
8402     # $DB::single = 1;
8403     $self->store_persistent_state;
8404 }
8405
8406 sub introduce_myself {
8407     my($self) = @_;
8408     $CPAN::Frontend->myprint(sprintf("  %s\n",$self->pretty_id));
8409 }
8410
8411 #-> sub CPAN::Distribution::dir ;
8412 sub dir {
8413     shift->{build_dir};
8414 }
8415
8416 #-> sub CPAN::Distribution::perldoc ;
8417 sub perldoc {
8418     my($self) = @_;
8419
8420     my($dist) = $self->id;
8421     my $package = $self->called_for;
8422
8423     $self->_display_url( $CPAN::Defaultdocs . $package );
8424 }
8425
8426 #-> sub CPAN::Distribution::_check_binary ;
8427 sub _check_binary {
8428     my ($dist,$shell,$binary) = @_;
8429     my ($pid,$out);
8430
8431     $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
8432       if $CPAN::DEBUG;
8433
8434     if ($CPAN::META->has_inst("File::Which")) {
8435         return File::Which::which($binary);
8436     } else {
8437         local *README;
8438         $pid = open README, "which $binary|"
8439             or $CPAN::Frontend->mywarn(qq{Could not fork 'which $binary': $!\n});
8440         return unless $pid;
8441         while (<README>) {
8442             $out .= $_;
8443         }
8444         close README
8445             or $CPAN::Frontend->mywarn("Could not run 'which $binary': $!\n")
8446                 and return;
8447     }
8448
8449     $CPAN::Frontend->myprint(qq{   + $out \n})
8450       if $CPAN::DEBUG && $out;
8451
8452     return $out;
8453 }
8454
8455 #-> sub CPAN::Distribution::_display_url ;
8456 sub _display_url {
8457     my($self,$url) = @_;
8458     my($res,$saved_file,$pid,$out);
8459
8460     $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
8461       if $CPAN::DEBUG;
8462
8463     # should we define it in the config instead?
8464     my $html_converter = "html2text";
8465
8466     my $web_browser = $CPAN::Config->{'lynx'} || undef;
8467     my $web_browser_out = $web_browser
8468       ? CPAN::Distribution->_check_binary($self,$web_browser)
8469         : undef;
8470
8471     if ($web_browser_out) {
8472         # web browser found, run the action
8473         my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
8474         $CPAN::Frontend->myprint(qq{system[$browser $url]})
8475           if $CPAN::DEBUG;
8476         $CPAN::Frontend->myprint(qq{
8477 Displaying URL
8478   $url
8479 with browser $browser
8480 });
8481         $CPAN::Frontend->mysleep(1);
8482         system("$browser $url");
8483         if ($saved_file) { 1 while unlink($saved_file) }
8484     } else {
8485         # web browser not found, let's try text only
8486         my $html_converter_out =
8487           CPAN::Distribution->_check_binary($self,$html_converter);
8488         $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out);
8489
8490         if ($html_converter_out ) {
8491             # html2text found, run it
8492             $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
8493             $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n})
8494                 unless defined($saved_file);
8495
8496             local *README;
8497             $pid = open README, "$html_converter $saved_file |"
8498               or $CPAN::Frontend->mydie(qq{
8499 Could not fork '$html_converter $saved_file': $!});
8500             my($fh,$filename);
8501             if ($CPAN::META->has_inst("File::Temp")) {
8502                 $fh = File::Temp->new(
8503                                       template => 'cpan_htmlconvert_XXXX',
8504                                       suffix => '.txt',
8505                                       unlink => 0,
8506                                      );
8507                 $filename = $fh->filename;
8508             } else {
8509                 $filename = "cpan_htmlconvert_$$.txt";
8510                 $fh = FileHandle->new();
8511                 open $fh, ">$filename" or die;
8512             }
8513             while (<README>) {
8514                 $fh->print($_);
8515             }
8516             close README or
8517                 $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
8518             my $tmpin = $fh->filename;
8519             $CPAN::Frontend->myprint(sprintf(qq{
8520 Run '%s %s' and
8521 saved output to %s\n},
8522                                              $html_converter,
8523                                              $saved_file,
8524                                              $tmpin,
8525                                             )) if $CPAN::DEBUG;
8526             close $fh;
8527             local *FH;
8528             open FH, $tmpin
8529                 or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
8530             my $fh_pager = FileHandle->new;
8531             local($SIG{PIPE}) = "IGNORE";
8532             my $pager = $CPAN::Config->{'pager'} || "cat";
8533             $fh_pager->open("|$pager")
8534                 or $CPAN::Frontend->mydie(qq{
8535 Could not open pager '$pager': $!});
8536             $CPAN::Frontend->myprint(qq{
8537 Displaying URL
8538   $url
8539 with pager "$pager"
8540 });
8541             $CPAN::Frontend->mysleep(1);
8542             $fh_pager->print(<FH>);
8543             $fh_pager->close;
8544         } else {
8545             # coldn't find the web browser or html converter
8546             $CPAN::Frontend->myprint(qq{
8547 You need to install lynx or $html_converter to use this feature.});
8548         }
8549     }
8550 }
8551
8552 #-> sub CPAN::Distribution::_getsave_url ;
8553 sub _getsave_url {
8554     my($dist, $shell, $url) = @_;
8555
8556     $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
8557       if $CPAN::DEBUG;
8558
8559     my($fh,$filename);
8560     if ($CPAN::META->has_inst("File::Temp")) {
8561         $fh = File::Temp->new(
8562                               template => "cpan_getsave_url_XXXX",
8563                               suffix => ".html",
8564                               unlink => 0,
8565                              );
8566         $filename = $fh->filename;
8567     } else {
8568         $fh = FileHandle->new;
8569         $filename = "cpan_getsave_url_$$.html";
8570     }
8571     my $tmpin = $filename;
8572     if ($CPAN::META->has_usable('LWP')) {
8573         $CPAN::Frontend->myprint("Fetching with LWP:
8574   $url
8575 ");
8576         my $Ua;
8577         CPAN::LWP::UserAgent->config;
8578         eval { $Ua = CPAN::LWP::UserAgent->new; };
8579         if ($@) {
8580             $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
8581             return;
8582         } else {
8583             my($var);
8584             $Ua->proxy('http', $var)
8585                 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
8586             $Ua->no_proxy($var)
8587                 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
8588         }
8589
8590         my $req = HTTP::Request->new(GET => $url);
8591         $req->header('Accept' => 'text/html');
8592         my $res = $Ua->request($req);
8593         if ($res->is_success) {
8594             $CPAN::Frontend->myprint(" + request successful.\n")
8595                 if $CPAN::DEBUG;
8596             print $fh $res->content;
8597             close $fh;
8598             $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
8599                 if $CPAN::DEBUG;
8600             return $tmpin;
8601         } else {
8602             $CPAN::Frontend->myprint(sprintf(
8603                                              "LWP failed with code[%s], message[%s]\n",
8604                                              $res->code,
8605                                              $res->message,
8606                                             ));
8607             return;
8608         }
8609     } else {
8610         $CPAN::Frontend->mywarn("  LWP not available\n");
8611         return;
8612     }
8613 }
8614
8615 # sub CPAN::Distribution::_build_command
8616 sub _build_command {
8617     my($self) = @_;
8618     if ($^O eq "MSWin32") { # special code needed at least up to
8619                             # Module::Build 0.2611 and 0.2706; a fix
8620                             # in M:B has been promised 2006-01-30
8621         my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
8622         return "$perl ./Build";
8623     }
8624     return "./Build";
8625 }
8626
8627 package CPAN::Bundle;
8628 use strict;
8629
8630 sub look {
8631     my $self = shift;
8632     $CPAN::Frontend->myprint($self->as_string);
8633 }
8634
8635 sub undelay {
8636     my $self = shift;
8637     delete $self->{later};
8638     for my $c ( $self->contains ) {
8639         my $obj = CPAN::Shell->expandany($c) or next;
8640         $obj->undelay;
8641     }
8642 }
8643
8644 # mark as dirty/clean
8645 #-> sub CPAN::Bundle::color_cmd_tmps ;
8646 sub color_cmd_tmps {
8647     my($self) = shift;
8648     my($depth) = shift || 0;
8649     my($color) = shift || 0;
8650     my($ancestors) = shift || [];
8651     # a module needs to recurse to its cpan_file, a distribution needs
8652     # to recurse into its prereq_pms, a bundle needs to recurse into its modules
8653
8654     return if exists $self->{incommandcolor}
8655         && $color==1
8656         && $self->{incommandcolor}==$color;
8657     if ($depth>=$CPAN::MAX_RECURSION){
8658         die(CPAN::Exception::RecursiveDependency->new($ancestors));
8659     }
8660     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
8661
8662     for my $c ( $self->contains ) {
8663         my $obj = CPAN::Shell->expandany($c) or next;
8664         CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
8665         $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
8666     }
8667     # never reached code?
8668     #if ($color==0) {
8669       #delete $self->{badtestcnt};
8670     #}
8671     $self->{incommandcolor} = $color;
8672 }
8673
8674 #-> sub CPAN::Bundle::as_string ;
8675 sub as_string {
8676     my($self) = @_;
8677     $self->contains;
8678     # following line must be "=", not "||=" because we have a moving target
8679     $self->{INST_VERSION} = $self->inst_version;
8680     return $self->SUPER::as_string;
8681 }
8682
8683 #-> sub CPAN::Bundle::contains ;
8684 sub contains {
8685     my($self) = @_;
8686     my($inst_file) = $self->inst_file || "";
8687     my($id) = $self->id;
8688     $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
8689     if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) {
8690         undef $inst_file;
8691     }
8692     unless ($inst_file) {
8693         # Try to get at it in the cpan directory
8694         $self->debug("no inst_file") if $CPAN::DEBUG;
8695         my $cpan_file;
8696         $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
8697               $cpan_file = $self->cpan_file;
8698         if ($cpan_file eq "N/A") {
8699             $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
8700   Maybe stale symlink? Maybe removed during session? Giving up.\n");
8701         }
8702         my $dist = $CPAN::META->instance('CPAN::Distribution',
8703                                          $self->cpan_file);
8704         $self->debug("before get id[$dist->{ID}]") if $CPAN::DEBUG;
8705         $dist->get;
8706         $self->debug("after get id[$dist->{ID}]") if $CPAN::DEBUG;
8707         my($todir) = $CPAN::Config->{'cpan_home'};
8708         my(@me,$from,$to,$me);
8709         @me = split /::/, $self->id;
8710         $me[-1] .= ".pm";
8711         $me = File::Spec->catfile(@me);
8712         $from = $self->find_bundle_file($dist->{build_dir},join('/',@me));
8713         $to = File::Spec->catfile($todir,$me);
8714         File::Path::mkpath(File::Basename::dirname($to));
8715         File::Copy::copy($from, $to)
8716               or Carp::confess("Couldn't copy $from to $to: $!");
8717         $inst_file = $to;
8718     }
8719     my @result;
8720     my $fh = FileHandle->new;
8721     local $/ = "\n";
8722     open($fh,$inst_file) or die "Could not open '$inst_file': $!";
8723     my $in_cont = 0;
8724     $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
8725     while (<$fh>) {
8726         $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
8727             m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
8728         next unless $in_cont;
8729         next if /^=/;
8730         s/\#.*//;
8731         next if /^\s+$/;
8732         chomp;
8733         push @result, (split " ", $_, 2)[0];
8734     }
8735     close $fh;
8736     delete $self->{STATUS};
8737     $self->{CONTAINS} = \@result;
8738     $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
8739     unless (@result) {
8740         $CPAN::Frontend->mywarn(qq{
8741 The bundle file "$inst_file" may be a broken
8742 bundlefile. It seems not to contain any bundle definition.
8743 Please check the file and if it is bogus, please delete it.
8744 Sorry for the inconvenience.
8745 });
8746     }
8747     @result;
8748 }
8749
8750 #-> sub CPAN::Bundle::find_bundle_file
8751 # $where is in local format, $what is in unix format
8752 sub find_bundle_file {
8753     my($self,$where,$what) = @_;
8754     $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
8755 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
8756 ###    my $bu = File::Spec->catfile($where,$what);
8757 ###    return $bu if -f $bu;
8758     my $manifest = File::Spec->catfile($where,"MANIFEST");
8759     unless (-f $manifest) {
8760         require ExtUtils::Manifest;
8761         my $cwd = CPAN::anycwd();
8762         $self->safe_chdir($where);
8763         ExtUtils::Manifest::mkmanifest();
8764         $self->safe_chdir($cwd);
8765     }
8766     my $fh = FileHandle->new($manifest)
8767         or Carp::croak("Couldn't open $manifest: $!");
8768     local($/) = "\n";
8769     my $bundle_filename = $what;
8770     $bundle_filename =~ s|Bundle.*/||;
8771     my $bundle_unixpath;
8772     while (<$fh>) {
8773         next if /^\s*\#/;
8774         my($file) = /(\S+)/;
8775         if ($file =~ m|\Q$what\E$|) {
8776             $bundle_unixpath = $file;
8777             # return File::Spec->catfile($where,$bundle_unixpath); # bad
8778             last;
8779         }
8780         # retry if she managed to have no Bundle directory
8781         $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
8782     }
8783     return File::Spec->catfile($where, split /\//, $bundle_unixpath)
8784         if $bundle_unixpath;
8785     Carp::croak("Couldn't find a Bundle file in $where");
8786 }
8787
8788 # needs to work quite differently from Module::inst_file because of
8789 # cpan_home/Bundle/ directory and the possibility that we have
8790 # shadowing effect. As it makes no sense to take the first in @INC for
8791 # Bundles, we parse them all for $VERSION and take the newest.
8792
8793 #-> sub CPAN::Bundle::inst_file ;
8794 sub inst_file {
8795     my($self) = @_;
8796     my($inst_file);
8797     my(@me);
8798     @me = split /::/, $self->id;
8799     $me[-1] .= ".pm";
8800     my($incdir,$bestv);
8801     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
8802         my $bfile = File::Spec->catfile($incdir, @me);
8803         CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
8804         next unless -f $bfile;
8805         my $foundv = MM->parse_version($bfile);
8806         if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
8807             $self->{INST_FILE} = $bfile;
8808             $self->{INST_VERSION} = $bestv = $foundv;
8809         }
8810     }
8811     $self->{INST_FILE};
8812 }
8813
8814 #-> sub CPAN::Bundle::inst_version ;
8815 sub inst_version {
8816     my($self) = @_;
8817     $self->inst_file; # finds INST_VERSION as side effect
8818     $self->{INST_VERSION};
8819 }
8820
8821 #-> sub CPAN::Bundle::rematein ;
8822 sub rematein {
8823     my($self,$meth) = @_;
8824     $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
8825     my($id) = $self->id;
8826     Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
8827         unless $self->inst_file || $self->cpan_file;
8828     my($s,%fail);
8829     for $s ($self->contains) {
8830         my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
8831             $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
8832         if ($type eq 'CPAN::Distribution') {
8833             $CPAN::Frontend->mywarn(qq{
8834 The Bundle }.$self->id.qq{ contains
8835 explicitly a file '$s'.
8836 Going to $meth that.
8837 });
8838             $CPAN::Frontend->mysleep(5);
8839         }
8840         # possibly noisy action:
8841         $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
8842         my $obj = $CPAN::META->instance($type,$s);
8843         $obj->{reqtype} = $self->{reqtype};
8844         $obj->$meth();
8845     }
8846 }
8847
8848 # If a bundle contains another that contains an xs_file we have here,
8849 # we just don't bother I suppose
8850 #-> sub CPAN::Bundle::xs_file
8851 sub xs_file {
8852     return 0;
8853 }
8854
8855 #-> sub CPAN::Bundle::force ;
8856 sub fforce   { shift->rematein('fforce',@_); }
8857 #-> sub CPAN::Bundle::force ;
8858 sub force   { shift->rematein('force',@_); }
8859 #-> sub CPAN::Bundle::notest ;
8860 sub notest  { shift->rematein('notest',@_); }
8861 #-> sub CPAN::Bundle::get ;
8862 sub get     { shift->rematein('get',@_); }
8863 #-> sub CPAN::Bundle::make ;
8864 sub make    { shift->rematein('make',@_); }
8865 #-> sub CPAN::Bundle::test ;
8866 sub test    {
8867     my $self = shift;
8868     # $self->{badtestcnt} ||= 0;
8869     $self->rematein('test',@_);
8870 }
8871 #-> sub CPAN::Bundle::install ;
8872 sub install {
8873   my $self = shift;
8874   $self->rematein('install',@_);
8875 }
8876 #-> sub CPAN::Bundle::clean ;
8877 sub clean   { shift->rematein('clean',@_); }
8878
8879 #-> sub CPAN::Bundle::uptodate ;
8880 sub uptodate {
8881     my($self) = @_;
8882     return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
8883     my $c;
8884     foreach $c ($self->contains) {
8885         my $obj = CPAN::Shell->expandany($c);
8886         return 0 unless $obj->uptodate;
8887     }
8888     return 1;
8889 }
8890
8891 #-> sub CPAN::Bundle::readme ;
8892 sub readme  {
8893     my($self) = @_;
8894     my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
8895 No File found for bundle } . $self->id . qq{\n}), return;
8896     $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
8897     $CPAN::META->instance('CPAN::Distribution',$file)->readme;
8898 }
8899
8900 package CPAN::Module;
8901 use strict;
8902
8903 # Accessors
8904 # sub CPAN::Module::userid
8905 sub userid {
8906     my $self = shift;
8907     my $ro = $self->ro;
8908     return unless $ro;
8909     return $ro->{userid} || $ro->{CPAN_USERID};
8910 }
8911 # sub CPAN::Module::description
8912 sub description {
8913     my $self = shift;
8914     my $ro = $self->ro or return "";
8915     $ro->{description}
8916 }
8917
8918 sub distribution {
8919     my($self) = @_;
8920     CPAN::Shell->expand("Distribution",$self->cpan_file);
8921 }
8922
8923 # sub CPAN::Module::undelay
8924 sub undelay {
8925     my $self = shift;
8926     delete $self->{later};
8927     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
8928         $dist->undelay;
8929     }
8930 }
8931
8932 # mark as dirty/clean
8933 #-> sub CPAN::Module::color_cmd_tmps ;
8934 sub color_cmd_tmps {
8935     my($self) = shift;
8936     my($depth) = shift || 0;
8937     my($color) = shift || 0;
8938     my($ancestors) = shift || [];
8939     # a module needs to recurse to its cpan_file
8940
8941     return if exists $self->{incommandcolor}
8942         && $color==1
8943         && $self->{incommandcolor}==$color;
8944     return if $color==0 && !$self->{incommandcolor};
8945     if ($color>=1) {
8946         if ( $self->uptodate ) {
8947             $self->{incommandcolor} = $color;
8948             return;
8949         } elsif (my $have_version = $self->available_version) {
8950             # maybe what we have is good enough
8951             if (@$ancestors) {
8952                 my $who_asked_for_me = $ancestors->[-1];
8953                 my $obj = CPAN::Shell->expandany($who_asked_for_me);
8954                 if (0) {
8955                 } elsif ($obj->isa("CPAN::Bundle")) {
8956                     # bundles cannot specify a minimum version
8957                     return;
8958                 } elsif ($obj->isa("CPAN::Distribution")) {
8959                     if (my $prereq_pm = $obj->prereq_pm) {
8960                         for my $k (keys %$prereq_pm) {
8961                             if (my $want_version = $prereq_pm->{$k}{$self->id}) {
8962                                 if (CPAN::Version->vcmp($have_version,$want_version) >= 0) {
8963                                     $self->{incommandcolor} = $color;
8964                                     return;
8965                                 }
8966                             }
8967                         }
8968                     }
8969                 }
8970             }
8971         }
8972     } else {
8973         $self->{incommandcolor} = $color; # set me before recursion,
8974                                           # so we can break it
8975     }
8976     if ($depth>=$CPAN::MAX_RECURSION){
8977         die(CPAN::Exception::RecursiveDependency->new($ancestors));
8978     }
8979     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
8980
8981     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
8982         $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
8983     }
8984     # unreached code?
8985     # if ($color==0) {
8986     #    delete $self->{badtestcnt};
8987     # }
8988     $self->{incommandcolor} = $color;
8989 }
8990
8991 #-> sub CPAN::Module::as_glimpse ;
8992 sub as_glimpse {
8993     my($self) = @_;
8994     my(@m);
8995     my $class = ref($self);
8996     $class =~ s/^CPAN:://;
8997     my $color_on = "";
8998     my $color_off = "";
8999     if (
9000         $CPAN::Shell::COLOR_REGISTERED
9001         &&
9002         $CPAN::META->has_inst("Term::ANSIColor")
9003         &&
9004         $self->description
9005        ) {
9006         $color_on = Term::ANSIColor::color("green");
9007         $color_off = Term::ANSIColor::color("reset");
9008     }
9009     my $uptodateness = " ";
9010     if ($class eq "Bundle") {
9011     } elsif ($self->uptodate) {
9012         $uptodateness = "=";
9013     } elsif ($self->inst_version) {
9014         $uptodateness = "<";
9015     }
9016     push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n",
9017                      $class,
9018                      $uptodateness,
9019                      $color_on,
9020                      $self->id,
9021                      $color_off,
9022                      ($self->distribution ?
9023                       $self->distribution->pretty_id :
9024                       $self->cpan_userid
9025                      ),
9026                     );
9027     join "", @m;
9028 }
9029
9030 #-> sub CPAN::Module::dslip_status
9031 sub dslip_status {
9032     my($self) = @_;
9033     my($stat);
9034     # development status
9035     @{$stat->{D}}{qw,i c a b R M S,}     = qw,idea
9036                                               pre-alpha alpha beta released
9037                                               mature standard,;
9038     # support level
9039     @{$stat->{S}}{qw,m d u n a,}         = qw,mailing-list
9040                                               developer comp.lang.perl.*
9041                                               none abandoned,;
9042     # language
9043     @{$stat->{L}}{qw,p c + o h,}         = qw,perl C C++ other hybrid,;
9044     # interface
9045     @{$stat->{I}}{qw,f r O p h n,}       = qw,functions
9046                                               references+ties
9047                                               object-oriented pragma
9048                                               hybrid none,;
9049     # public licence
9050     @{$stat->{P}}{qw,p g l b a o d r n,} = qw,Standard-Perl
9051                                               GPL LGPL
9052                                               BSD Artistic
9053                                               open-source
9054                                               distribution_allowed
9055                                               restricted_distribution
9056                                               no_licence,;
9057     for my $x (qw(d s l i p)) {
9058         $stat->{$x}{' '} = 'unknown';
9059         $stat->{$x}{'?'} = 'unknown';
9060     }
9061     my $ro = $self->ro;
9062     return +{} unless $ro && $ro->{statd};
9063     return {
9064             D  => $ro->{statd},
9065             S  => $ro->{stats},
9066             L  => $ro->{statl},
9067             I  => $ro->{stati},
9068             P  => $ro->{statp},
9069             DV => $stat->{D}{$ro->{statd}},
9070             SV => $stat->{S}{$ro->{stats}},
9071             LV => $stat->{L}{$ro->{statl}},
9072             IV => $stat->{I}{$ro->{stati}},
9073             PV => $stat->{P}{$ro->{statp}},
9074            };
9075 }
9076
9077 #-> sub CPAN::Module::as_string ;
9078 sub as_string {
9079     my($self) = @_;
9080     my(@m);
9081     CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
9082     my $class = ref($self);
9083     $class =~ s/^CPAN:://;
9084     local($^W) = 0;
9085     push @m, $class, " id = $self->{ID}\n";
9086     my $sprintf = "    %-12s %s\n";
9087     push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
9088         if $self->description;
9089     my $sprintf2 = "    %-12s %s (%s)\n";
9090     my($userid);
9091     $userid = $self->userid;
9092     if ( $userid ){
9093         my $author;
9094         if ($author = CPAN::Shell->expand('Author',$userid)) {
9095           my $email = "";
9096           my $m; # old perls
9097           if ($m = $author->email) {
9098             $email = " <$m>";
9099           }
9100           push @m, sprintf(
9101                            $sprintf2,
9102                            'CPAN_USERID',
9103                            $userid,
9104                            $author->fullname . $email
9105                           );
9106         }
9107     }
9108     push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
9109         if $self->cpan_version;
9110     if (my $cpan_file = $self->cpan_file){
9111         push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
9112         if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
9113             my $upload_date = $dist->upload_date;
9114             if ($upload_date) {
9115                 push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
9116             }
9117         }
9118     }
9119     my $sprintf3 = "    %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n";
9120     my $dslip = $self->dslip_status;
9121     push @m, sprintf(
9122                      $sprintf3,
9123                      'DSLIP_STATUS',
9124                      @{$dslip}{qw(D S L I P DV SV LV IV PV)},
9125                     ) if $dslip->{D};
9126     my $local_file = $self->inst_file;
9127     unless ($self->{MANPAGE}) {
9128         my $manpage;
9129         if ($local_file) {
9130             $manpage = $self->manpage_headline($local_file);
9131         } else {
9132             # If we have already untarred it, we should look there
9133             my $dist = $CPAN::META->instance('CPAN::Distribution',
9134                                              $self->cpan_file);
9135             # warn "dist[$dist]";
9136             # mff=manifest file; mfh=manifest handle
9137             my($mff,$mfh);
9138             if (
9139                 $dist->{build_dir}
9140                 and
9141                 (-f  ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
9142                 and
9143                 $mfh = FileHandle->new($mff)
9144                ) {
9145                 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
9146                 my $lfre = $self->id; # local file RE
9147                 $lfre =~ s/::/./g;
9148                 $lfre .= "\\.pm\$";
9149                 my($lfl); # local file file
9150                 local $/ = "\n";
9151                 my(@mflines) = <$mfh>;
9152                 for (@mflines) {
9153                     s/^\s+//;
9154                     s/\s.*//s;
9155                 }
9156                 while (length($lfre)>5 and !$lfl) {
9157                     ($lfl) = grep /$lfre/, @mflines;
9158                     CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
9159                     $lfre =~ s/.+?\.//;
9160                 }
9161                 $lfl =~ s/\s.*//; # remove comments
9162                 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
9163                 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
9164                 # warn "lfl_abs[$lfl_abs]";
9165                 if (-f $lfl_abs) {
9166                     $manpage = $self->manpage_headline($lfl_abs);
9167                 }
9168             }
9169         }
9170         $self->{MANPAGE} = $manpage if $manpage;
9171     }
9172     my($item);
9173     for $item (qw/MANPAGE/) {
9174         push @m, sprintf($sprintf, $item, $self->{$item})
9175             if exists $self->{$item};
9176     }
9177     for $item (qw/CONTAINS/) {
9178         push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
9179             if exists $self->{$item} && @{$self->{$item}};
9180     }
9181     push @m, sprintf($sprintf, 'INST_FILE',
9182                      $local_file || "(not installed)");
9183     push @m, sprintf($sprintf, 'INST_VERSION',
9184                      $self->inst_version) if $local_file;
9185     join "", @m, "\n";
9186 }
9187
9188 sub manpage_headline {
9189   my($self,$local_file) = @_;
9190   my(@local_file) = $local_file;
9191   $local_file =~ s/\.pm(?!\n)\Z/.pod/;
9192   push @local_file, $local_file;
9193   my(@result,$locf);
9194   for $locf (@local_file) {
9195     next unless -f $locf;
9196     my $fh = FileHandle->new($locf)
9197         or $Carp::Frontend->mydie("Couldn't open $locf: $!");
9198     my $inpod = 0;
9199     local $/ = "\n";
9200     while (<$fh>) {
9201       $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
9202           m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
9203       next unless $inpod;
9204       next if /^=/;
9205       next if /^\s+$/;
9206       chomp;
9207       push @result, $_;
9208     }
9209     close $fh;
9210     last if @result;
9211   }
9212   for (@result) {
9213       s/^\s+//;
9214       s/\s+$//;
9215   }
9216   join " ", @result;
9217 }
9218
9219 #-> sub CPAN::Module::cpan_file ;
9220 # Note: also inherited by CPAN::Bundle
9221 sub cpan_file {
9222     my $self = shift;
9223     # CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
9224     unless ($self->ro) {
9225         CPAN::Index->reload;
9226     }
9227     my $ro = $self->ro;
9228     if ($ro && defined $ro->{CPAN_FILE}){
9229         return $ro->{CPAN_FILE};
9230     } else {
9231         my $userid = $self->userid;
9232         if ( $userid ) {
9233             if ($CPAN::META->exists("CPAN::Author",$userid)) {
9234                 my $author = $CPAN::META->instance("CPAN::Author",
9235                                                    $userid);
9236                 my $fullname = $author->fullname;
9237                 my $email = $author->email;
9238                 unless (defined $fullname && defined $email) {
9239                     return sprintf("Contact Author %s",
9240                                    $userid,
9241                                   );
9242                 }
9243                 return "Contact Author $fullname <$email>";
9244             } else {
9245                 return "Contact Author $userid (Email address not available)";
9246             }
9247         } else {
9248             return "N/A";
9249         }
9250     }
9251 }
9252
9253 #-> sub CPAN::Module::cpan_version ;
9254 sub cpan_version {
9255     my $self = shift;
9256
9257     my $ro = $self->ro;
9258     unless ($ro) {
9259         # Can happen with modules that are not on CPAN
9260         $ro = {};
9261     }
9262     $ro->{CPAN_VERSION} = 'undef'
9263         unless defined $ro->{CPAN_VERSION};
9264     $ro->{CPAN_VERSION};
9265 }
9266
9267 #-> sub CPAN::Module::force ;
9268 sub force {
9269     my($self) = @_;
9270     $self->{force_update} = 1;
9271 }
9272
9273 #-> sub CPAN::Module::fforce ;
9274 sub fforce {
9275     my($self) = @_;
9276     $self->{force_update} = 2;
9277 }
9278
9279 sub notest {
9280     my($self) = @_;
9281     # warn "XDEBUG: set notest for Module";
9282     $self->{'notest'}++;
9283 }
9284
9285 #-> sub CPAN::Module::rematein ;
9286 sub rematein {
9287     my($self,$meth) = @_;
9288     $CPAN::Frontend->myprint(sprintf("Running %s for module '%s'\n",
9289                                      $meth,
9290                                      $self->id));
9291     my $cpan_file = $self->cpan_file;
9292     if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
9293       $CPAN::Frontend->mywarn(sprintf qq{
9294   The module %s isn\'t available on CPAN.
9295
9296   Either the module has not yet been uploaded to CPAN, or it is
9297   temporary unavailable. Please contact the author to find out
9298   more about the status. Try 'i %s'.
9299 },
9300                               $self->id,
9301                               $self->id,
9302                              );
9303       return;
9304     }
9305     my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
9306     $pack->called_for($self->id);
9307     if (exists $self->{force_update}){
9308         if ($self->{force_update} == 2) {
9309             $pack->fforce($meth);
9310         } else {
9311             $pack->force($meth);
9312         }
9313     }
9314     $pack->notest($meth) if exists $self->{'notest'};
9315
9316     $pack->{reqtype} ||= "";
9317     CPAN->debug("dist-reqtype[$pack->{reqtype}]".
9318                 "self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG;
9319         if ($pack->{reqtype}) {
9320             if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) {
9321                 $pack->{reqtype} = $self->{reqtype};
9322                 if (
9323                     exists $pack->{install}
9324                     &&
9325                     (
9326                      UNIVERSAL::can($pack->{install},"failed") ?
9327                      $pack->{install}->failed :
9328                      $pack->{install} =~ /^NO/
9329                     )
9330                    ) {
9331                     delete $pack->{install};
9332                     $CPAN::Frontend->mywarn
9333                         ("Promoting $pack->{ID} from 'build_requires' to 'requires'");
9334                 }
9335             }
9336         } else {
9337             $pack->{reqtype} = $self->{reqtype};
9338         }
9339
9340     eval {
9341         $pack->$meth();
9342     };
9343     my $err = $@;
9344     $pack->unforce if $pack->can("unforce") && exists $self->{force_update};
9345     $pack->unnotest if $pack->can("unnotest") && exists $self->{'notest'};
9346     delete $self->{force_update};
9347     delete $self->{'notest'};
9348     if ($err) {
9349         die $err;
9350     }
9351 }
9352
9353 #-> sub CPAN::Module::perldoc ;
9354 sub perldoc { shift->rematein('perldoc') }
9355 #-> sub CPAN::Module::readme ;
9356 sub readme  { shift->rematein('readme') }
9357 #-> sub CPAN::Module::look ;
9358 sub look    { shift->rematein('look') }
9359 #-> sub CPAN::Module::cvs_import ;
9360 sub cvs_import { shift->rematein('cvs_import') }
9361 #-> sub CPAN::Module::get ;
9362 sub get     { shift->rematein('get',@_) }
9363 #-> sub CPAN::Module::make ;
9364 sub make    { shift->rematein('make') }
9365 #-> sub CPAN::Module::test ;
9366 sub test   {
9367     my $self = shift;
9368     # $self->{badtestcnt} ||= 0;
9369     $self->rematein('test',@_);
9370 }
9371 #-> sub CPAN::Module::uptodate ;
9372 sub uptodate {
9373     my($self) = @_;
9374     local($_); # protect against a bug in MakeMaker 6.17
9375     my($latest) = $self->cpan_version;
9376     $latest ||= 0;
9377     my($inst_file) = $self->inst_file;
9378     my($have) = 0;
9379     if (defined $inst_file) {
9380         $have = $self->inst_version;
9381     }
9382     local($^W)=0;
9383     if ($inst_file
9384         &&
9385         ! CPAN::Version->vgt($latest, $have)
9386        ) {
9387         CPAN->debug("returning uptodate. inst_file[$inst_file] ".
9388                     "latest[$latest] have[$have]") if $CPAN::DEBUG;
9389         return 1;
9390     }
9391     return;
9392 }
9393 #-> sub CPAN::Module::install ;
9394 sub install {
9395     my($self) = @_;
9396     my($doit) = 0;
9397     if ($self->uptodate
9398         &&
9399         not exists $self->{force_update}
9400        ) {
9401         $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
9402                                          $self->id,
9403                                          $self->inst_version,
9404                                         ));
9405     } else {
9406         $doit = 1;
9407     }
9408     my $ro = $self->ro;
9409     if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
9410         $CPAN::Frontend->mywarn(qq{
9411 \n\n\n     ***WARNING***
9412      The module $self->{ID} has no active maintainer.\n\n\n
9413 });
9414         $CPAN::Frontend->mysleep(5);
9415     }
9416     $self->rematein('install') if $doit;
9417 }
9418 #-> sub CPAN::Module::clean ;
9419 sub clean  { shift->rematein('clean') }
9420
9421 #-> sub CPAN::Module::inst_file ;
9422 sub inst_file {
9423     my($self) = @_;
9424     $self->_file_in_path([@INC]);
9425 }
9426
9427 #-> sub CPAN::Module::available_file ;
9428 sub available_file {
9429     my($self) = @_;
9430     my $sep = $Config::Config{path_sep};
9431     my $perllib = $ENV{PERL5LIB};
9432     $perllib = $ENV{PERLLIB} unless defined $perllib;
9433     my @perllib = split(/$sep/,$perllib) if defined $perllib;
9434     $self->_file_in_path([@perllib,@INC]);
9435 }
9436
9437 #-> sub CPAN::Module::file_in_path ;
9438 sub _file_in_path {
9439     my($self,$path) = @_;
9440     my($dir,@packpath);
9441     @packpath = split /::/, $self->{ID};
9442     $packpath[-1] .= ".pm";
9443     if (@packpath == 1 && $packpath[0] eq "readline.pm") {
9444         unshift @packpath, "Term", "ReadLine"; # historical reasons
9445     }
9446     foreach $dir (@$path) {
9447         my $pmfile = File::Spec->catfile($dir,@packpath);
9448         if (-f $pmfile){
9449             return $pmfile;
9450         }
9451     }
9452     return;
9453 }
9454
9455 #-> sub CPAN::Module::xs_file ;
9456 sub xs_file {
9457     my($self) = @_;
9458     my($dir,@packpath);
9459     @packpath = split /::/, $self->{ID};
9460     push @packpath, $packpath[-1];
9461     $packpath[-1] .= "." . $Config::Config{'dlext'};
9462     foreach $dir (@INC) {
9463         my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
9464         if (-f $xsfile){
9465             return $xsfile;
9466         }
9467     }
9468     return;
9469 }
9470
9471 #-> sub CPAN::Module::inst_version ;
9472 sub inst_version {
9473     my($self) = @_;
9474     my $parsefile = $self->inst_file or return;
9475     my $have = $self->parse_version($parsefile);
9476     $have;
9477 }
9478
9479 #-> sub CPAN::Module::inst_version ;
9480 sub available_version {
9481     my($self) = @_;
9482     my $parsefile = $self->available_file or return;
9483     my $have = $self->parse_version($parsefile);
9484     $have;
9485 }
9486
9487 #-> sub CPAN::Module::parse_version ;
9488 sub parse_version {
9489     my($self,$parsefile) = @_;
9490     my $have = MM->parse_version($parsefile);
9491     $have = "undef" unless defined $have && length $have;
9492     $have =~ s/^ //; # since the %vd hack these two lines here are needed
9493     $have =~ s/ $//; # trailing whitespace happens all the time
9494
9495     $have = CPAN::Version->readable($have);
9496
9497     $have =~ s/\s*//g; # stringify to float around floating point issues
9498     $have; # no stringify needed, \s* above matches always
9499 }
9500
9501 package CPAN;
9502 use strict;
9503
9504 1;
9505
9506
9507 __END__
9508
9509 =head1 NAME
9510
9511 CPAN - query, download and build perl modules from CPAN sites
9512
9513 =head1 SYNOPSIS
9514
9515 Interactive mode:
9516
9517   perl -MCPAN -e shell
9518
9519 --or--
9520
9521   cpan
9522
9523 Basic commands:
9524
9525   # Modules:
9526
9527   cpan> install Acme::Meta                       # in the shell
9528
9529   CPAN::Shell->install("Acme::Meta");            # in perl
9530
9531   # Distributions:
9532
9533   cpan> install NWCLARK/Acme-Meta-0.02.tar.gz    # in the shell
9534
9535   CPAN::Shell->
9536     install("NWCLARK/Acme-Meta-0.02.tar.gz");    # in perl
9537
9538   # module objects:
9539
9540   $mo = CPAN::Shell->expandany($mod);
9541   $mo = CPAN::Shell->expand("Module",$mod);      # same thing
9542
9543   # distribution objects:
9544
9545   $do = CPAN::Shell->expand("Module",$mod)->distribution;
9546   $do = CPAN::Shell->expandany($distro);         # same thing
9547   $do = CPAN::Shell->expand("Distribution",
9548                             $distro);            # same thing
9549
9550 =head1 DESCRIPTION
9551
9552 The CPAN module automates or at least simplifies the make and install
9553 of perl modules and extensions. It includes some primitive searching
9554 capabilities and knows how to use Net::FTP or LWP or some external
9555 download clients to fetch the distributions from the net.
9556
9557 These are fetched from one or more of the mirrored CPAN (Comprehensive
9558 Perl Archive Network) sites and unpacked in a dedicated directory.
9559
9560 The CPAN module also supports the concept of named and versioned
9561 I<bundles> of modules. Bundles simplify the handling of sets of
9562 related modules. See Bundles below.
9563
9564 The package contains a session manager and a cache manager. The
9565 session manager keeps track of what has been fetched, built and
9566 installed in the current session. The cache manager keeps track of the
9567 disk space occupied by the make processes and deletes excess space
9568 according to a simple FIFO mechanism.
9569
9570 All methods provided are accessible in a programmer style and in an
9571 interactive shell style.
9572
9573 =head2 CPAN::shell([$prompt, $command]) Starting Interactive Mode
9574
9575 The interactive mode is entered by running
9576
9577     perl -MCPAN -e shell
9578
9579 or
9580
9581     cpan
9582
9583 which puts you into a readline interface. If C<Term::ReadKey> and
9584 either C<Term::ReadLine::Perl> or C<Term::ReadLine::Gnu> are installed
9585 it supports both history and command completion.
9586
9587 Once you are on the command line, type C<h> to get a one page help
9588 screen and the rest should be self-explanatory.
9589
9590 The function call C<shell> takes two optional arguments, one is the
9591 prompt, the second is the default initial command line (the latter
9592 only works if a real ReadLine interface module is installed).
9593
9594 The most common uses of the interactive modes are
9595
9596 =over 2
9597
9598 =item Searching for authors, bundles, distribution files and modules
9599
9600 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
9601 for each of the four categories and another, C<i> for any of the
9602 mentioned four. Each of the four entities is implemented as a class
9603 with slightly differing methods for displaying an object.
9604
9605 Arguments you pass to these commands are either strings exactly matching
9606 the identification string of an object or regular expressions that are
9607 then matched case-insensitively against various attributes of the
9608 objects. The parser recognizes a regular expression only if you
9609 enclose it between two slashes.
9610
9611 The principle is that the number of found objects influences how an
9612 item is displayed. If the search finds one item, the result is
9613 displayed with the rather verbose method C<as_string>, but if we find
9614 more than one, we display each object with the terse method
9615 C<as_glimpse>.
9616
9617 =item C<get>, C<make>, C<test>, C<install>, C<clean> modules or distributions
9618
9619 These commands take any number of arguments and investigate what is
9620 necessary to perform the action. If the argument is a distribution
9621 file name (recognized by embedded slashes), it is processed. If it is
9622 a module, CPAN determines the distribution file in which this module
9623 is included and processes that, following any dependencies named in
9624 the module's META.yml or Makefile.PL (this behavior is controlled by
9625 the configuration parameter C<prerequisites_policy>.)
9626
9627 C<get> downloads a distribution file and untars or unzips it, C<make>
9628 builds it, C<test> runs the test suite, and C<install> installs it.
9629
9630 Any C<make> or C<test> are run unconditionally. An
9631
9632   install <distribution_file>
9633
9634 also is run unconditionally. But for
9635
9636   install <module>
9637
9638 CPAN checks if an install is actually needed for it and prints
9639 I<module up to date> in the case that the distribution file containing
9640 the module doesn't need to be updated.
9641
9642 CPAN also keeps track of what it has done within the current session
9643 and doesn't try to build a package a second time regardless if it
9644 succeeded or not. It does not repeat a test run if the test
9645 has been run successfully before. Same for install runs.
9646
9647 The C<force> pragma may precede another command (currently: C<get>,
9648 C<make>, C<test>, or C<install>) and executes the command from scratch
9649 and tries to continue in case of some errors. See the section below on
9650 the C<force> and the C<fforce> pragma.
9651
9652 The C<notest> pragma may be used to skip the test part in the build
9653 process.
9654
9655 Example:
9656
9657     cpan> notest install Tk
9658
9659 A C<clean> command results in a
9660
9661   make clean
9662
9663 being executed within the distribution file's working directory.
9664
9665 =item C<readme>, C<perldoc>, C<look> module or distribution
9666
9667 C<readme> displays the README file of the associated distribution.
9668 C<Look> gets and untars (if not yet done) the distribution file,
9669 changes to the appropriate directory and opens a subshell process in
9670 that directory. C<perldoc> displays the pod documentation of the
9671 module in html or plain text format.
9672
9673 =item C<ls> author
9674
9675 =item C<ls> globbing_expression
9676
9677 The first form lists all distribution files in and below an author's
9678 CPAN directory as they are stored in the CHECKUMS files distributed on
9679 CPAN. The listing goes recursive into all subdirectories.
9680
9681 The second form allows to limit or expand the output with shell
9682 globbing as in the following examples:
9683
9684           ls JV/make*
9685           ls GSAR/*make*
9686           ls */*make*
9687
9688 The last example is very slow and outputs extra progress indicators
9689 that break the alignment of the result.
9690
9691 Note that globbing only lists directories explicitly asked for, for
9692 example FOO/* will not list FOO/bar/Acme-Sthg-n.nn.tar.gz. This may be
9693 regarded as a bug and may be changed in future versions.
9694
9695 =item C<failed>
9696
9697 The C<failed> command reports all distributions that failed on one of
9698 C<make>, C<test> or C<install> for some reason in the currently
9699 running shell session.
9700
9701 =item Persistence between sessions
9702
9703 If the C<YAML> or the c<YAML::Syck> module is installed a record of
9704 the internal state of all modules is written to disk after each step.
9705 The files contain a signature of the currently running perl version
9706 for later perusal.
9707
9708 If the configurations variable C<build_dir_reuse> is set to a true
9709 value, then CPAN.pm reads the collected YAML files. If the stored
9710 signature matches the currently running perl the stored state is
9711 loaded into memory such that effectively persistence between sessions
9712 is established.
9713
9714 =item The C<force> and the C<fforce> pragma
9715
9716 To speed things up in complex installation scenarios, CPAN.pm keeps
9717 track of what it has already done and refuses to do some things a
9718 second time. A C<get>, a C<make>, and an C<install> are not repeated.
9719 A C<test> is only repeated if the previous test was unsuccessful. The
9720 diagnostic message when CPAN.pm refuses to do something a second time
9721 is one of I<Has already been >C<unwrapped|made|tested successfully> or
9722 something similar. Another situation where CPAN refuses to act is an
9723 C<install> if the according C<test> was not successful.
9724
9725 In all these cases, the user can override the goatish behaviour by
9726 prepending the command with the word force, for example:
9727
9728   cpan> force get Foo
9729   cpan> force make AUTHOR/Bar-3.14.tar.gz
9730   cpan> force test Baz
9731   cpan> force install Acme::Meta
9732
9733 Each I<forced> command is executed with the according part of its
9734 memory erased.
9735
9736 The C<fforce> pragma is a variant that emulates a C<force get> which
9737 erases the entire memory followed by the action specified, effectively
9738 restarting the whole get/make/test/install procedure from scratch.
9739
9740 =item Lockfile
9741
9742 Interactive sessions maintain a lockfile, per default C<~/.cpan/.lock>.
9743 Batch jobs can run without a lockfile and do not disturb each other.
9744
9745 The shell offers to run in I<degraded mode> when another process is
9746 holding the lockfile. This is an experimental feature that is not yet
9747 tested very well. This second shell then does not write the history
9748 file, does not use the metadata file and has a different prompt.
9749
9750 =item Signals
9751
9752 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
9753 in the cpan-shell it is intended that you can press C<^C> anytime and
9754 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
9755 to clean up and leave the shell loop. You can emulate the effect of a
9756 SIGTERM by sending two consecutive SIGINTs, which usually means by
9757 pressing C<^C> twice.
9758
9759 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
9760 SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl
9761 Build.PL> subprocess.
9762
9763 =back
9764
9765 =head2 CPAN::Shell
9766
9767 The commands that are available in the shell interface are methods in
9768 the package CPAN::Shell. If you enter the shell command, all your
9769 input is split by the Text::ParseWords::shellwords() routine which
9770 acts like most shells do. The first word is being interpreted as the
9771 method to be called and the rest of the words are treated as arguments
9772 to this method. Continuation lines are supported if a line ends with a
9773 literal backslash.
9774
9775 =head2 autobundle
9776
9777 C<autobundle> writes a bundle file into the
9778 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
9779 a list of all modules that are both available from CPAN and currently
9780 installed within @INC. The name of the bundle file is based on the
9781 current date and a counter.
9782
9783 =head2 hosts
9784
9785 Note: this feature is still in alpha state and may change in future
9786 versions of CPAN.pm
9787
9788 This commands provides a statistical overview over recent download
9789 activities. The data for this is collected in the YAML file
9790 C<FTPstats.yml> in your C<cpan_home> directory. If no YAML module is
9791 configured or YAML not installed, then no stats are provided.
9792
9793 =head2 mkmyconfig
9794
9795 mkmyconfig() writes your own CPAN::MyConfig file into your ~/.cpan/
9796 directory so that you can save your own preferences instead of the
9797 system wide ones.
9798
9799 =head2 recompile
9800
9801 recompile() is a very special command in that it takes no argument and
9802 runs the make/test/install cycle with brute force over all installed
9803 dynamically loadable extensions (aka XS modules) with 'force' in
9804 effect. The primary purpose of this command is to finish a network
9805 installation. Imagine, you have a common source tree for two different
9806 architectures. You decide to do a completely independent fresh
9807 installation. You start on one architecture with the help of a Bundle
9808 file produced earlier. CPAN installs the whole Bundle for you, but
9809 when you try to repeat the job on the second architecture, CPAN
9810 responds with a C<"Foo up to date"> message for all modules. So you
9811 invoke CPAN's recompile on the second architecture and you're done.
9812
9813 Another popular use for C<recompile> is to act as a rescue in case your
9814 perl breaks binary compatibility. If one of the modules that CPAN uses
9815 is in turn depending on binary compatibility (so you cannot run CPAN
9816 commands), then you should try the CPAN::Nox module for recovery.
9817
9818 =head2 report Bundle|Distribution|Module
9819
9820 The C<report> command temporarily turns on the C<test_report> config
9821 variable, then runs the C<force test> command with the given
9822 arguments. The C<force> pragma is used to re-run the tests and repeat
9823 every step that might have failed before.
9824
9825 =head2 upgrade [Module|/Regex/]...
9826
9827 The C<upgrade> command first runs an C<r> command with the given
9828 arguments and then installs the newest versions of all modules that
9829 were listed by that.
9830
9831 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
9832
9833 Although it may be considered internal, the class hierarchy does matter
9834 for both users and programmer. CPAN.pm deals with above mentioned four
9835 classes, and all those classes share a set of methods. A classical
9836 single polymorphism is in effect. A metaclass object registers all
9837 objects of all kinds and indexes them with a string. The strings
9838 referencing objects have a separated namespace (well, not completely
9839 separated):
9840
9841          Namespace                         Class
9842
9843    words containing a "/" (slash)      Distribution
9844     words starting with Bundle::          Bundle
9845           everything else            Module or Author
9846
9847 Modules know their associated Distribution objects. They always refer
9848 to the most recent official release. Developers may mark their releases
9849 as unstable development versions (by inserting an underbar into the
9850 module version number which will also be reflected in the distribution
9851 name when you run 'make dist'), so the really hottest and newest
9852 distribution is not always the default.  If a module Foo circulates
9853 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
9854 way to install version 1.23 by saying
9855
9856     install Foo
9857
9858 This would install the complete distribution file (say
9859 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
9860 like to install version 1.23_90, you need to know where the
9861 distribution file resides on CPAN relative to the authors/id/
9862 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
9863 so you would have to say
9864
9865     install BAR/Foo-1.23_90.tar.gz
9866
9867 The first example will be driven by an object of the class
9868 CPAN::Module, the second by an object of class CPAN::Distribution.
9869
9870 =head2 Integrating local directories
9871
9872 Note: this feature is still in alpha state and may change in future
9873 versions of CPAN.pm
9874
9875 Distribution objects are normally distributions from the CPAN, but
9876 there is a slightly degenerate case for Distribution objects, too, of
9877 projects held on the local disk. These distribution objects have the
9878 same name as the local directory and end with a dot. A dot by itself
9879 is also allowed for the current directory at the time CPAN.pm was
9880 used. All actions such as C<make>, C<test>, and C<install> are applied
9881 directly to that directory. This gives the command C<cpan .> an
9882 interesting touch: while the normal mantra of installing a CPAN module
9883 without CPAN.pm is one of
9884
9885     perl Makefile.PL                 perl Build.PL
9886            ( go and get prerequisites )
9887     make                             ./Build
9888     make test                        ./Build test
9889     make install                     ./Build install
9890
9891 the command C<cpan .> does all of this at once. It figures out which
9892 of the two mantras is appropriate, fetches and installs all
9893 prerequisites, cares for them recursively and finally finishes the
9894 installation of the module in the current directory, be it a CPAN
9895 module or not.
9896
9897 The typical usage case is for private modules or working copies of
9898 projects from remote repositories on the local disk.
9899
9900 =head1 CONFIGURATION
9901
9902 When the CPAN module is used for the first time, a configuration
9903 dialog tries to determine a couple of site specific options. The
9904 result of the dialog is stored in a hash reference C< $CPAN::Config >
9905 in a file CPAN/Config.pm.
9906
9907 The default values defined in the CPAN/Config.pm file can be
9908 overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
9909 best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
9910 added to the search path of the CPAN module before the use() or
9911 require() statements. The mkmyconfig command writes this file for you.
9912
9913 The C<o conf> command has various bells and whistles:
9914
9915 =over
9916
9917 =item completion support
9918
9919 If you have a ReadLine module installed, you can hit TAB at any point
9920 of the commandline and C<o conf> will offer you completion for the
9921 built-in subcommands and/or config variable names.
9922
9923 =item displaying some help: o conf help
9924
9925 Displays a short help
9926
9927 =item displaying current values: o conf [KEY]
9928
9929 Displays the current value(s) for this config variable. Without KEY
9930 displays all subcommands and config variables.
9931
9932 Example:
9933
9934   o conf shell
9935
9936 =item changing of scalar values: o conf KEY VALUE
9937
9938 Sets the config variable KEY to VALUE. The empty string can be
9939 specified as usual in shells, with C<''> or C<"">
9940
9941 Example:
9942
9943   o conf wget /usr/bin/wget
9944
9945 =item changing of list values: o conf KEY SHIFT|UNSHIFT|PUSH|POP|SPLICE|LIST
9946
9947 If a config variable name ends with C<list>, it is a list. C<o conf
9948 KEY shift> removes the first element of the list, C<o conf KEY pop>
9949 removes the last element of the list. C<o conf KEYS unshift LIST>
9950 prepends a list of values to the list, C<o conf KEYS push LIST>
9951 appends a list of valued to the list.
9952
9953 Likewise, C<o conf KEY splice LIST> passes the LIST to the according
9954 splice command.
9955
9956 Finally, any other list of arguments is taken as a new list value for
9957 the KEY variable discarding the previous value.
9958
9959 Examples:
9960
9961   o conf urllist unshift http://cpan.dev.local/CPAN
9962   o conf urllist splice 3 1
9963   o conf urllist http://cpan1.local http://cpan2.local ftp://ftp.perl.org
9964
9965 =item reverting to saved: o conf defaults
9966
9967 Reverts all config variables to the state in the saved config file.
9968
9969 =item saving the config: o conf commit
9970
9971 Saves all config variables to the current config file (CPAN/Config.pm
9972 or CPAN/MyConfig.pm that was loaded at start).
9973
9974 =back
9975
9976 The configuration dialog can be started any time later again by
9977 issuing the command C< o conf init > in the CPAN shell. A subset of
9978 the configuration dialog can be run by issuing C<o conf init WORD>
9979 where WORD is any valid config variable or a regular expression.
9980
9981 =head2 Config Variables
9982
9983 Currently the following keys in the hash reference $CPAN::Config are
9984 defined:
9985
9986   applypatch         path to external prg
9987   auto_commit        commit all changes to config variables to disk
9988   build_cache        size of cache for directories to build modules
9989   build_dir          locally accessible directory to build modules
9990   build_dir_reuse    boolean if distros in build_dir are persistent
9991   build_requires_install_policy
9992                      to install or not to install when a module is
9993                      only needed for building. yes|no|ask/yes|ask/no
9994   bzip2              path to external prg
9995   cache_metadata     use serializer to cache metadata
9996   commands_quote     prefered character to use for quoting external
9997                      commands when running them. Defaults to double
9998                      quote on Windows, single tick everywhere else;
9999                      can be set to space to disable quoting
10000   check_sigs         if signatures should be verified
10001   colorize_debug     Term::ANSIColor attributes for debugging output
10002   colorize_output    boolean if Term::ANSIColor should colorize output
10003   colorize_print     Term::ANSIColor attributes for normal output
10004   colorize_warn      Term::ANSIColor attributes for warnings
10005   commandnumber_in_prompt
10006                      boolean if you want to see current command number
10007   cpan_home          local directory reserved for this package
10008   curl               path to external prg
10009   dontload_hash      DEPRECATED
10010   dontload_list      arrayref: modules in the list will not be
10011                      loaded by the CPAN::has_inst() routine
10012   ftp                path to external prg
10013   ftp_passive        if set, the envariable FTP_PASSIVE is set for downloads
10014   ftp_proxy          proxy host for ftp requests
10015   getcwd             see below
10016   gpg                path to external prg
10017   gzip               location of external program gzip
10018   histfile           file to maintain history between sessions
10019   histsize           maximum number of lines to keep in histfile
10020   http_proxy         proxy host for http requests
10021   inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
10022                      after this many seconds inactivity. Set to 0 to
10023                      never break.
10024   index_expire       after this many days refetch index files
10025   inhibit_startup_message
10026                      if true, does not print the startup message
10027   keep_source_where  directory in which to keep the source (if we do)
10028   lynx               path to external prg
10029   make               location of external make program
10030   make_arg           arguments that should always be passed to 'make'
10031   make_install_make_command
10032                      the make command for running 'make install', for
10033                      example 'sudo make'
10034   make_install_arg   same as make_arg for 'make install'
10035   makepl_arg         arguments passed to 'perl Makefile.PL'
10036   mbuild_arg         arguments passed to './Build'
10037   mbuild_install_arg arguments passed to './Build install'
10038   mbuild_install_build_command
10039                      command to use instead of './Build' when we are
10040                      in the install stage, for example 'sudo ./Build'
10041   mbuildpl_arg       arguments passed to 'perl Build.PL'
10042   ncftp              path to external prg
10043   ncftpget           path to external prg
10044   no_proxy           don't proxy to these hosts/domains (comma separated list)
10045   pager              location of external program more (or any pager)
10046   password           your password if you CPAN server wants one
10047   patch              path to external prg
10048   prefer_installer   legal values are MB and EUMM: if a module comes
10049                      with both a Makefile.PL and a Build.PL, use the
10050                      former (EUMM) or the latter (MB); if the module
10051                      comes with only one of the two, that one will be
10052                      used in any case
10053   prerequisites_policy
10054                      what to do if you are missing module prerequisites
10055                      ('follow' automatically, 'ask' me, or 'ignore')
10056   prefs_dir          local directory to store per-distro build options
10057   proxy_user         username for accessing an authenticating proxy
10058   proxy_pass         password for accessing an authenticating proxy
10059   randomize_urllist  add some randomness to the sequence of the urllist
10060   scan_cache         controls scanning of cache ('atstart' or 'never')
10061   shell              your favorite shell
10062   show_upload_date   boolean if commands should try to determine upload date
10063   tar                location of external program tar
10064   term_is_latin      if true internal UTF-8 is translated to ISO-8859-1
10065                      (and nonsense for characters outside latin range)
10066   term_ornaments     boolean to turn ReadLine ornamenting on/off
10067   test_report        email test reports (if CPAN::Reporter is installed)
10068   unzip              location of external program unzip
10069   urllist            arrayref to nearby CPAN sites (or equivalent locations)
10070   use_sqlite         use CPAN::SQLite for metadata storage (fast and lean)
10071   username           your username if you CPAN server wants one
10072   wait_list          arrayref to a wait server to try (See CPAN::WAIT)
10073   wget               path to external prg
10074   yaml_module        which module to use to read/write YAML files
10075
10076 You can set and query each of these options interactively in the cpan
10077 shell with the C<o conf> or the C<o conf init> command as specified below.
10078
10079 =over 2
10080
10081 =item C<o conf E<lt>scalar optionE<gt>>
10082
10083 prints the current value of the I<scalar option>
10084
10085 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
10086
10087 Sets the value of the I<scalar option> to I<value>
10088
10089 =item C<o conf E<lt>list optionE<gt>>
10090
10091 prints the current value of the I<list option> in MakeMaker's
10092 neatvalue format.
10093
10094 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
10095
10096 shifts or pops the array in the I<list option> variable
10097
10098 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
10099
10100 works like the corresponding perl commands.
10101
10102 =item interactive editing: o conf init [MATCH|LIST]
10103
10104 Runs an interactive configuration dialog for matching variables.
10105 Without argument runs the dialog over all supported config variables.
10106 To specify a MATCH the argument must be enclosed by slashes.
10107
10108 Examples:
10109
10110   o conf init ftp_passive ftp_proxy
10111   o conf init /color/
10112
10113 Note: this method of setting config variables often provides more
10114 explanation about the functioning of a variable than the manpage.
10115
10116 =back
10117
10118 =head2 CPAN::anycwd($path): Note on config variable getcwd
10119
10120 CPAN.pm changes the current working directory often and needs to
10121 determine its own current working directory. Per default it uses
10122 Cwd::cwd but if this doesn't work on your system for some reason,
10123 alternatives can be configured according to the following table:
10124
10125 =over 4
10126
10127 =item cwd
10128
10129 Calls Cwd::cwd
10130
10131 =item getcwd
10132
10133 Calls Cwd::getcwd
10134
10135 =item fastcwd
10136
10137 Calls Cwd::fastcwd
10138
10139 =item backtickcwd
10140
10141 Calls the external command cwd.
10142
10143 =back
10144
10145 =head2 Note on the format of the urllist parameter
10146
10147 urllist parameters are URLs according to RFC 1738. We do a little
10148 guessing if your URL is not compliant, but if you have problems with
10149 C<file> URLs, please try the correct format. Either:
10150
10151     file://localhost/whatever/ftp/pub/CPAN/
10152
10153 or
10154
10155     file:///home/ftp/pub/CPAN/
10156
10157 =head2 The urllist parameter has CD-ROM support
10158
10159 The C<urllist> parameter of the configuration table contains a list of
10160 URLs that are to be used for downloading. If the list contains any
10161 C<file> URLs, CPAN always tries to get files from there first. This
10162 feature is disabled for index files. So the recommendation for the
10163 owner of a CD-ROM with CPAN contents is: include your local, possibly
10164 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
10165
10166   o conf urllist push file://localhost/CDROM/CPAN
10167
10168 CPAN.pm will then fetch the index files from one of the CPAN sites
10169 that come at the beginning of urllist. It will later check for each
10170 module if there is a local copy of the most recent version.
10171
10172 Another peculiarity of urllist is that the site that we could
10173 successfully fetch the last file from automatically gets a preference
10174 token and is tried as the first site for the next request. So if you
10175 add a new site at runtime it may happen that the previously preferred
10176 site will be tried another time. This means that if you want to disallow
10177 a site for the next transfer, it must be explicitly removed from
10178 urllist.
10179
10180 =head2 Maintaining the urllist parameter
10181
10182 If you have YAML.pm (or some other YAML module configured in
10183 C<yaml_module>) installed, CPAN.pm collects a few statistical data
10184 about recent downloads. You can view the statistics with the C<hosts>
10185 command or inspect them directly by looking into the C<FTPstats.yml>
10186 file in your C<cpan_home> directory.
10187
10188 To get some interesting statistics it is recommended to set the
10189 C<randomize_urllist> parameter that introduces some amount of
10190 randomness into the URL selection.
10191
10192 =head2 The C<requires> and C<build_requires> dependency declarations
10193
10194 Since CPAN.pm version 1.88_51 modules declared as C<build_requires> by
10195 a distribution are treated differently depending on the config
10196 variable C<build_requires_install_policy>. By setting
10197 C<build_requires_install_policy> to C<no> such a module is not being
10198 installed. It is only built and tested and then kept in the list of
10199 tested but uninstalled modules. As such it is available during the
10200 build of the dependent module by integrating the path to the
10201 C<blib/arch> and C<blib/lib> directories in the environment variable
10202 PERL5LIB. If C<build_requires_install_policy> is set ti C<yes>, then
10203 both modules declared as C<requires> and those declared as
10204 C<build_requires> are treated alike. By setting to C<ask/yes> or
10205 C<ask/no>, CPAN.pm asks the user and sets the default accordingly.
10206
10207 =head2 Configuration for individual distributions (I<Distroprefs>)
10208
10209 (B<Note:> This feature has been introduced in CPAN.pm 1.8854 and is
10210 still considered beta quality)
10211
10212 Distributions on the CPAN usually behave according to what we call the
10213 CPAN mantra. Or since the event of Module::Build we should talk about
10214 two mantras:
10215
10216     perl Makefile.PL     perl Build.PL
10217     make                 ./Build
10218     make test            ./Build test
10219     make install         ./Build install
10220
10221 But some modules cannot be built with this mantra. They try to get
10222 some extra data from the user via the environment, extra arguments or
10223 interactively thus disturbing the installation of large bundles like
10224 Phalanx100 or modules with many dependencies like Plagger.
10225
10226 The distroprefs system of C<CPAN.pm> addresses this problem by
10227 allowing the user to specify extra informations and recipes in YAML
10228 files to either
10229
10230 =over
10231
10232 =item
10233
10234 pass additional arguments to one of the four commands,
10235
10236 =item
10237
10238 set environment variables
10239
10240 =item
10241
10242 instantiate an Expect object that reads from the console, waits for
10243 some regular expressions and enters some answers
10244
10245 =item
10246
10247 temporarily override assorted C<CPAN.pm> configuration variables
10248
10249 =item
10250
10251 disable the installation of an object altogether
10252
10253 =back
10254
10255 See the YAML and Data::Dumper files that come with the C<CPAN.pm>
10256 distribution in the C<distroprefs/> directory for examples.
10257
10258 =head2 Filenames
10259
10260 The YAML files themselves must have the C<.yml> extension, all other
10261 files are ignored (for two exceptions see I<Fallback Data::Dumper and
10262 Storable> below). The containing directory can be specified in
10263 C<CPAN.pm> in the C<prefs_dir> config variable. Try C<o conf init
10264 prefs_dir> in the CPAN shell to set and activate the distroprefs
10265 system.
10266
10267 Every YAML file may contain arbitrary documents according to the YAML
10268 specification and every single document is treated as an entity that
10269 can specify the treatment of a single distribution.
10270
10271 The names of the files can be picked freely, C<CPAN.pm> always reads
10272 all files (in alphabetical order) and takes the key C<match> (see
10273 below in I<Language Specs>) as a hashref containing match criteria
10274 that determine if the current distribution matches the YAML document
10275 or not.
10276
10277 =head2 Fallback Data::Dumper and Storable
10278
10279 If neither your configured C<yaml_module> nor YAML.pm is installed
10280 CPAN.pm falls back to using Data::Dumper and Storable and looks for
10281 files with the extensions C<.dd> or C<.st> in the C<prefs_dir>
10282 directory. These files are expected to contain one or more hashrefs.
10283 For Data::Dumper generated files, this is expected to be done with by
10284 defining C<$VAR1>, C<$VAR2>, etc. The YAML shell would produce these
10285 with the command
10286
10287     ysh < somefile.yml > somefile.dd
10288
10289 For Storable files the rule is that they must be constructed such that
10290 C<Storable::retrieve(file)> returns an array reference and the array
10291 elements represent one distropref object each. The conversion from
10292 YAML would look like so:
10293
10294     perl -MYAML=LoadFile -MStorable=nstore -e '
10295         @y=LoadFile(shift);
10296         nstore(\@y, shift)' somefile.yml somefile.st
10297
10298 In bootstrapping situations it is usually sufficient to translate only
10299 a few YAML files to Data::Dumper for the crucial modules like
10300 C<YAML::Syck>, C<YAML.pm> and C<Expect.pm>. If you prefer Storable
10301 over Data::Dumper, remember to pull out a Storable version that writes
10302 an older format than all the other Storable versions that will need to
10303 read them.
10304
10305 =head2 Blueprint
10306
10307 The following example contains all supported keywords and structures
10308 with the exception of C<eexpect> which can be used instead of
10309 C<expect>.
10310
10311   ---
10312   comment: "Demo"
10313   match:
10314     module: "Dancing::Queen"
10315     distribution: "^CHACHACHA/Dancing-"
10316     perl: "/usr/local/cariba-perl/bin/perl"
10317     perlconfig:
10318       archname: "freebsd"
10319   disabled: 1
10320   cpanconfig:
10321     make: gmake
10322   pl:
10323     args:
10324       - "--somearg=specialcase"
10325
10326     env: {}
10327
10328     expect:
10329       - "Which is your favorite fruit"
10330       - "apple\n"
10331
10332   make:
10333     args:
10334       - all
10335       - extra-all
10336
10337     env: {}
10338
10339     expect: []
10340
10341     commendline: "echo SKIPPING make"
10342
10343   test:
10344     args: []
10345
10346     env: {}
10347
10348     expect: []
10349
10350   install:
10351     args: []
10352
10353     env:
10354       WANT_TO_INSTALL: YES
10355
10356     expect:
10357       - "Do you really want to install"
10358       - "y\n"
10359
10360   patches:
10361     - "ABCDE/Fedcba-3.14-ABCDE-01.patch"
10362
10363
10364 =head2 Language Specs
10365
10366 Every YAML document represents a single hash reference. The valid keys
10367 in this hash are as follows:
10368
10369 =over
10370
10371 =item comment [scalar]
10372
10373 A comment
10374
10375 =item cpanconfig [hash]
10376
10377 Temporarily override assorted C<CPAN.pm> configuration variables.
10378
10379 Supported are: C<build_requires_install_policy>, C<check_sigs>,
10380 C<make>, C<make_install_make_command>, C<prefer_installer>,
10381 C<test_report>. Please report as a bug when you need another one
10382 supported.
10383
10384 =item disabled [boolean]
10385
10386 Specifies that this distribution shall not be processed at all.
10387
10388 =item goto [string]
10389
10390 The canonical name of a delegate distribution that shall be installed
10391 instead. Useful when a new version, although it tests OK itself,
10392 breaks something else or a developer release or a fork is already
10393 uploaded that is better than the last released version.
10394
10395 =item install [hash]
10396
10397 Processing instructions for the C<make install> or C<./Build install>
10398 phase of the CPAN mantra. See below under I<Processiong Instructions>.
10399
10400 =item make [hash]
10401
10402 Processing instructions for the C<make> or C<./Build> phase of the
10403 CPAN mantra. See below under I<Processiong Instructions>.
10404
10405 =item match [hash]
10406
10407 A hashref with one or more of the keys C<distribution>, C<modules>,
10408 C<perl>, and C<perlconfig> that specify if a document is targeted at a
10409 specific CPAN distribution or installation.
10410
10411 The corresponding values are interpreted as regular expressions. The
10412 C<distribution> related one will be matched against the canonical
10413 distribution name, e.g. "AUTHOR/Foo-Bar-3.14.tar.gz".
10414
10415 The C<module> related one will be matched against I<all> modules
10416 contained in the distribution until one module matches.
10417
10418 The C<perl> related one will be matched against C<$^X>.
10419
10420 The value associated with C<perlconfig> is itself a hashref that is
10421 matched against corresponding values in the C<%Config::Config> hash
10422 living in the C< Config.pm > module.
10423
10424 If more than one restriction of C<module>, C<distribution>, and
10425 C<perl> is specified, the results of the separately computed match
10426 values must all match. If this is the case then the hashref
10427 represented by the YAML document is returned as the preference
10428 structure for the current distribution.
10429
10430 =item patches [array]
10431
10432 An array of patches on CPAN or on the local disk to be applied in
10433 order via the external patch program. If the value for the C<-p>
10434 parameter is C<0> or C<1> is determined by reading the patch
10435 beforehand.
10436
10437 Note: if the C<applypatch> program is installed and C<CPAN::Config>
10438 knows about it B<and> a patch is written by the C<makepatch> program,
10439 then C<CPAN.pm> lets C<applypatch> apply the patch. Both C<makepatch>
10440 and C<applypatch> are available from CPAN in the C<JV/makepatch-*>
10441 distribution.
10442
10443 =item pl [hash]
10444
10445 Processing instructions for the C<perl Makefile.PL> or C<perl
10446 Build.PL> phase of the CPAN mantra. See below under I<Processiong
10447 Instructions>.
10448
10449 =item test [hash]
10450
10451 Processing instructions for the C<make test> or C<./Build test> phase
10452 of the CPAN mantra. See below under I<Processiong Instructions>.
10453
10454 =back
10455
10456 =head2 Processing Instructions
10457
10458 =over
10459
10460 =item args [array]
10461
10462 Arguments to be added to the command line
10463
10464 =item commandline
10465
10466 A full commandline that will be executed as it stands by a system
10467 call. During the execution the environment variable PERL will is set
10468 to $^X. If C<commandline> is specified, the content of C<args> is not
10469 used.
10470
10471 =item eexpect [hash]
10472
10473 Extended C<expect>. This is a hash reference with three allowed keys,
10474 C<mode>, C<timeout>, and C<talk>.
10475
10476 C<mode> may have the values C<deterministic> for the case where all
10477 questions come in the order written down and C<anyorder> for the case
10478 where the questions may come in any order. The default mode is
10479 C<deterministic>.
10480
10481 C<timeout> denotes a timeout in seconds. Floating point timeouts are
10482 OK. In the case of a C<mode=deterministic> the timeout denotes the
10483 timeout per question, in the case of C<mode=anyorder> it denotes the
10484 timeout per byte received from the stream or questions.
10485
10486 C<talk> is a reference to an array that contains alternating questions
10487 and answers. Questions are regular expressions and answers are literal
10488 strings. The Expect module will then watch the stream coming from the
10489 execution of the external program (C<perl Makefile.PL>, C<perl
10490 Build.PL>, C<make>, etc.).
10491
10492 In the case of C<mode=deterministic> the CPAN.pm will inject the
10493 according answer as soon as the stream matches the regular expression.
10494 In the case of C<mode=anyorder> the CPAN.pm will answer a question as
10495 soon as the timeout is reached for the next byte in the input stream.
10496 In the latter case it removes the according question/answer pair from
10497 the array, so if you want to answer the question C<Do you really want
10498 to do that> several times, then it must be included in the array at
10499 least as often as you want this answer to be given.
10500
10501 =item env [hash]
10502
10503 Environment variables to be set during the command
10504
10505 =item expect [array]
10506
10507 C<< expect: <array> >> is a short notation for
10508
10509   eexpect:
10510     mode: deterministic
10511     timeout: 15
10512     talk: <array>
10513
10514 =back
10515
10516 =head2 Schema verification with C<Kwalify>
10517
10518 If you have the C<Kwalify> module installed (which is part of the
10519 Bundle::CPANxxl), then all your distroprefs files are checked for
10520 syntactical correctness.
10521
10522 =head2 Example Distroprefs Files
10523
10524 C<CPAN.pm> comes with a collection of example YAML files. Note that these
10525 are really just examples and should not be used without care because
10526 they cannot fit everybody's purpose. After all the authors of the
10527 packages that ask questions had a need to ask, so you should watch
10528 their questions and adjust the examples to your environment and your
10529 needs. You have beend warned:-)
10530
10531 =head1 PROGRAMMER'S INTERFACE
10532
10533 If you do not enter the shell, the available shell commands are both
10534 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
10535 functions in the calling package (C<install(...)>).  Before calling low-level
10536 commands it makes sense to initialize components of CPAN you need, e.g.:
10537
10538   CPAN::HandleConfig->load;
10539   CPAN::Shell::setup_output;
10540   CPAN::Index->reload;
10541
10542 High-level commands do such initializations automatically.
10543
10544 There's currently only one class that has a stable interface -
10545 CPAN::Shell. All commands that are available in the CPAN shell are
10546 methods of the class CPAN::Shell. Each of the commands that produce
10547 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
10548 the IDs of all modules within the list.
10549
10550 =over 2
10551
10552 =item expand($type,@things)
10553
10554 The IDs of all objects available within a program are strings that can
10555 be expanded to the corresponding real objects with the
10556 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
10557 list of CPAN::Module objects according to the C<@things> arguments
10558 given. In scalar context it only returns the first element of the
10559 list.
10560
10561 =item expandany(@things)
10562
10563 Like expand, but returns objects of the appropriate type, i.e.
10564 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
10565 CPAN::Distribution objects for distributions. Note: it does not expand
10566 to CPAN::Author objects.
10567
10568 =item Programming Examples
10569
10570 This enables the programmer to do operations that combine
10571 functionalities that are available in the shell.
10572
10573     # install everything that is outdated on my disk:
10574     perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
10575
10576     # install my favorite programs if necessary:
10577     for $mod (qw(Net::FTP Digest::SHA Data::Dumper)){
10578         CPAN::Shell->install($mod);
10579     }
10580
10581     # list all modules on my disk that have no VERSION number
10582     for $mod (CPAN::Shell->expand("Module","/./")){
10583         next unless $mod->inst_file;
10584         # MakeMaker convention for undefined $VERSION:
10585         next unless $mod->inst_version eq "undef";
10586         print "No VERSION in ", $mod->id, "\n";
10587     }
10588
10589     # find out which distribution on CPAN contains a module:
10590     print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
10591
10592 Or if you want to write a cronjob to watch The CPAN, you could list
10593 all modules that need updating. First a quick and dirty way:
10594
10595     perl -e 'use CPAN; CPAN::Shell->r;'
10596
10597 If you don't want to get any output in the case that all modules are
10598 up to date, you can parse the output of above command for the regular
10599 expression //modules are up to date// and decide to mail the output
10600 only if it doesn't match. Ick?
10601
10602 If you prefer to do it more in a programmer style in one single
10603 process, maybe something like this suits you better:
10604
10605   # list all modules on my disk that have newer versions on CPAN
10606   for $mod (CPAN::Shell->expand("Module","/./")){
10607     next unless $mod->inst_file;
10608     next if $mod->uptodate;
10609     printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
10610         $mod->id, $mod->inst_version, $mod->cpan_version;
10611   }
10612
10613 If that gives you too much output every day, you maybe only want to
10614 watch for three modules. You can write
10615
10616   for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
10617
10618 as the first line instead. Or you can combine some of the above
10619 tricks:
10620
10621   # watch only for a new mod_perl module
10622   $mod = CPAN::Shell->expand("Module","mod_perl");
10623   exit if $mod->uptodate;
10624   # new mod_perl arrived, let me know all update recommendations
10625   CPAN::Shell->r;
10626
10627 =back
10628
10629 =head2 Methods in the other Classes
10630
10631 =over 4
10632
10633 =item CPAN::Author::as_glimpse()
10634
10635 Returns a one-line description of the author
10636
10637 =item CPAN::Author::as_string()
10638
10639 Returns a multi-line description of the author
10640
10641 =item CPAN::Author::email()
10642
10643 Returns the author's email address
10644
10645 =item CPAN::Author::fullname()
10646
10647 Returns the author's name
10648
10649 =item CPAN::Author::name()
10650
10651 An alias for fullname
10652
10653 =item CPAN::Bundle::as_glimpse()
10654
10655 Returns a one-line description of the bundle
10656
10657 =item CPAN::Bundle::as_string()
10658
10659 Returns a multi-line description of the bundle
10660
10661 =item CPAN::Bundle::clean()
10662
10663 Recursively runs the C<clean> method on all items contained in the bundle.
10664
10665 =item CPAN::Bundle::contains()
10666
10667 Returns a list of objects' IDs contained in a bundle. The associated
10668 objects may be bundles, modules or distributions.
10669
10670 =item CPAN::Bundle::force($method,@args)
10671
10672 Forces CPAN to perform a task that it normally would have refused to
10673 do. Force takes as arguments a method name to be called and any number
10674 of additional arguments that should be passed to the called method.
10675 The internals of the object get the needed changes so that CPAN.pm
10676 does not refuse to take the action. The C<force> is passed recursively
10677 to all contained objects. See also the section above on the C<force>
10678 and the C<fforce> pragma.
10679
10680 =item CPAN::Bundle::get()
10681
10682 Recursively runs the C<get> method on all items contained in the bundle
10683
10684 =item CPAN::Bundle::inst_file()
10685
10686 Returns the highest installed version of the bundle in either @INC or
10687 C<$CPAN::Config->{cpan_home}>. Note that this is different from
10688 CPAN::Module::inst_file.
10689
10690 =item CPAN::Bundle::inst_version()
10691
10692 Like CPAN::Bundle::inst_file, but returns the $VERSION
10693
10694 =item CPAN::Bundle::uptodate()
10695
10696 Returns 1 if the bundle itself and all its members are uptodate.
10697
10698 =item CPAN::Bundle::install()
10699
10700 Recursively runs the C<install> method on all items contained in the bundle
10701
10702 =item CPAN::Bundle::make()
10703
10704 Recursively runs the C<make> method on all items contained in the bundle
10705
10706 =item CPAN::Bundle::readme()
10707
10708 Recursively runs the C<readme> method on all items contained in the bundle
10709
10710 =item CPAN::Bundle::test()
10711
10712 Recursively runs the C<test> method on all items contained in the bundle
10713
10714 =item CPAN::Distribution::as_glimpse()
10715
10716 Returns a one-line description of the distribution
10717
10718 =item CPAN::Distribution::as_string()
10719
10720 Returns a multi-line description of the distribution
10721
10722 =item CPAN::Distribution::author
10723
10724 Returns the CPAN::Author object of the maintainer who uploaded this
10725 distribution
10726
10727 =item CPAN::Distribution::clean()
10728
10729 Changes to the directory where the distribution has been unpacked and
10730 runs C<make clean> there.
10731
10732 =item CPAN::Distribution::containsmods()
10733
10734 Returns a list of IDs of modules contained in a distribution file.
10735 Only works for distributions listed in the 02packages.details.txt.gz
10736 file. This typically means that only the most recent version of a
10737 distribution is covered.
10738
10739 =item CPAN::Distribution::cvs_import()
10740
10741 Changes to the directory where the distribution has been unpacked and
10742 runs something like
10743
10744     cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
10745
10746 there.
10747
10748 =item CPAN::Distribution::dir()
10749
10750 Returns the directory into which this distribution has been unpacked.
10751
10752 =item CPAN::Distribution::force($method,@args)
10753
10754 Forces CPAN to perform a task that it normally would have refused to
10755 do. Force takes as arguments a method name to be called and any number
10756 of additional arguments that should be passed to the called method.
10757 The internals of the object get the needed changes so that CPAN.pm
10758 does not refuse to take the action. See also the section above on the
10759 C<force> and the C<fforce> pragma.
10760
10761 =item CPAN::Distribution::get()
10762
10763 Downloads the distribution from CPAN and unpacks it. Does nothing if
10764 the distribution has already been downloaded and unpacked within the
10765 current session.
10766
10767 =item CPAN::Distribution::install()
10768
10769 Changes to the directory where the distribution has been unpacked and
10770 runs the external command C<make install> there. If C<make> has not
10771 yet been run, it will be run first. A C<make test> will be issued in
10772 any case and if this fails, the install will be canceled. The
10773 cancellation can be avoided by letting C<force> run the C<install> for
10774 you.
10775
10776 This install method has only the power to install the distribution if
10777 there are no dependencies in the way. To install an object and all of
10778 its dependencies, use CPAN::Shell->install.
10779
10780 Note that install() gives no meaningful return value. See uptodate().
10781
10782 =item CPAN::Distribution::install_tested()
10783
10784 Install all the distributions that have been tested sucessfully but
10785 not yet installed. See also C<is_tested>.
10786
10787 =item CPAN::Distribution::isa_perl()
10788
10789 Returns 1 if this distribution file seems to be a perl distribution.
10790 Normally this is derived from the file name only, but the index from
10791 CPAN can contain a hint to achieve a return value of true for other
10792 filenames too.
10793
10794 =item CPAN::Distribution::is_tested()
10795
10796 List all the distributions that have been tested sucessfully but not
10797 yet installed. See also C<install_tested>.
10798
10799 =item CPAN::Distribution::look()
10800
10801 Changes to the directory where the distribution has been unpacked and
10802 opens a subshell there. Exiting the subshell returns.
10803
10804 =item CPAN::Distribution::make()
10805
10806 First runs the C<get> method to make sure the distribution is
10807 downloaded and unpacked. Changes to the directory where the
10808 distribution has been unpacked and runs the external commands C<perl
10809 Makefile.PL> or C<perl Build.PL> and C<make> there.
10810
10811 =item CPAN::Distribution::perldoc()
10812
10813 Downloads the pod documentation of the file associated with a
10814 distribution (in html format) and runs it through the external
10815 command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
10816 isn't available, it converts it to plain text with external
10817 command html2text and runs it through the pager specified
10818 in C<$CPAN::Config->{pager}>
10819
10820 =item CPAN::Distribution::prefs()
10821
10822 Returns the hash reference from the first matching YAML file that the
10823 user has deposited in the C<prefs_dir/> directory. The first
10824 succeeding match wins. The files in the C<prefs_dir/> are processed
10825 alphabetically and the canonical distroname (e.g.
10826 AUTHOR/Foo-Bar-3.14.tar.gz) is matched against the regular expressions
10827 stored in the $root->{match}{distribution} attribute value.
10828 Additionally all module names contained in a distribution are matched
10829 agains the regular expressions in the $root->{match}{module} attribute
10830 value. The two match values are ANDed together. Each of the two
10831 attributes are optional.
10832
10833 =item CPAN::Distribution::prereq_pm()
10834
10835 Returns the hash reference that has been announced by a distribution
10836 as the the C<requires> and C<build_requires> elements. These can be
10837 declared either by the C<META.yml> (if authoritative) or can be
10838 deposited after the run of C<Build.PL> in the file C<./_build/prereqs>
10839 or after the run of C<Makfile.PL> written as the C<PREREQ_PM> hash in
10840 a comment in the produced C<Makefile>. I<Note>: this method only works
10841 after an attempt has been made to C<make> the distribution. Returns
10842 undef otherwise.
10843
10844 =item CPAN::Distribution::readme()
10845
10846 Downloads the README file associated with a distribution and runs it
10847 through the pager specified in C<$CPAN::Config->{pager}>.
10848
10849 =item CPAN::Distribution::read_yaml()
10850
10851 Returns the content of the META.yml of this distro as a hashref. Note:
10852 works only after an attempt has been made to C<make> the distribution.
10853 Returns undef otherwise. Also returns undef if the content of META.yml
10854 is not authoritative. (The rules about what exactly makes the content
10855 authoritative are still in flux.)
10856
10857 =item CPAN::Distribution::test()
10858
10859 Changes to the directory where the distribution has been unpacked and
10860 runs C<make test> there.
10861
10862 =item CPAN::Distribution::uptodate()
10863
10864 Returns 1 if all the modules contained in the distribution are
10865 uptodate. Relies on containsmods.
10866
10867 =item CPAN::Index::force_reload()
10868
10869 Forces a reload of all indices.
10870
10871 =item CPAN::Index::reload()
10872
10873 Reloads all indices if they have not been read for more than
10874 C<$CPAN::Config->{index_expire}> days.
10875
10876 =item CPAN::InfoObj::dump()
10877
10878 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
10879 inherit this method. It prints the data structure associated with an
10880 object. Useful for debugging. Note: the data structure is considered
10881 internal and thus subject to change without notice.
10882
10883 =item CPAN::Module::as_glimpse()
10884
10885 Returns a one-line description of the module in four columns: The
10886 first column contains the word C<Module>, the second column consists
10887 of one character: an equals sign if this module is already installed
10888 and uptodate, a less-than sign if this module is installed but can be
10889 upgraded, and a space if the module is not installed. The third column
10890 is the name of the module and the fourth column gives maintainer or
10891 distribution information.
10892
10893 =item CPAN::Module::as_string()
10894
10895 Returns a multi-line description of the module
10896
10897 =item CPAN::Module::clean()
10898
10899 Runs a clean on the distribution associated with this module.
10900
10901 =item CPAN::Module::cpan_file()
10902
10903 Returns the filename on CPAN that is associated with the module.
10904
10905 =item CPAN::Module::cpan_version()
10906
10907 Returns the latest version of this module available on CPAN.
10908
10909 =item CPAN::Module::cvs_import()
10910
10911 Runs a cvs_import on the distribution associated with this module.
10912
10913 =item CPAN::Module::description()
10914
10915 Returns a 44 character description of this module. Only available for
10916 modules listed in The Module List (CPAN/modules/00modlist.long.html
10917 or 00modlist.long.txt.gz)
10918
10919 =item CPAN::Module::distribution()
10920
10921 Returns the CPAN::Distribution object that contains the current
10922 version of this module.
10923
10924 =item CPAN::Module::dslip_status()
10925
10926 Returns a hash reference. The keys of the hash are the letters C<D>,
10927 C<S>, C<L>, C<I>, and <P>, for development status, support level,
10928 language, interface and public licence respectively. The data for the
10929 DSLIP status are collected by pause.perl.org when authors register
10930 their namespaces. The values of the 5 hash elements are one-character
10931 words whose meaning is described in the table below. There are also 5
10932 hash elements C<DV>, C<SV>, C<LV>, C<IV>, and <PV> that carry a more
10933 verbose value of the 5 status variables.
10934
10935 Where the 'DSLIP' characters have the following meanings:
10936
10937   D - Development Stage  (Note: *NO IMPLIED TIMESCALES*):
10938     i   - Idea, listed to gain consensus or as a placeholder
10939     c   - under construction but pre-alpha (not yet released)
10940     a/b - Alpha/Beta testing
10941     R   - Released
10942     M   - Mature (no rigorous definition)
10943     S   - Standard, supplied with Perl 5
10944
10945   S - Support Level:
10946     m   - Mailing-list
10947     d   - Developer
10948     u   - Usenet newsgroup comp.lang.perl.modules
10949     n   - None known, try comp.lang.perl.modules
10950     a   - abandoned; volunteers welcome to take over maintainance
10951
10952   L - Language Used:
10953     p   - Perl-only, no compiler needed, should be platform independent
10954     c   - C and perl, a C compiler will be needed
10955     h   - Hybrid, written in perl with optional C code, no compiler needed
10956     +   - C++ and perl, a C++ compiler will be needed
10957     o   - perl and another language other than C or C++
10958
10959   I - Interface Style
10960     f   - plain Functions, no references used
10961     h   - hybrid, object and function interfaces available
10962     n   - no interface at all (huh?)
10963     r   - some use of unblessed References or ties
10964     O   - Object oriented using blessed references and/or inheritance
10965
10966   P - Public License
10967     p   - Standard-Perl: user may choose between GPL and Artistic
10968     g   - GPL: GNU General Public License
10969     l   - LGPL: "GNU Lesser General Public License" (previously known as
10970           "GNU Library General Public License")
10971     b   - BSD: The BSD License
10972     a   - Artistic license alone
10973     o   - open source: appoved by www.opensource.org
10974     d   - allows distribution without restrictions
10975     r   - restricted distribtion
10976     n   - no license at all
10977
10978 =item CPAN::Module::force($method,@args)
10979
10980 Forces CPAN to perform a task that it normally would have refused to
10981 do. Force takes as arguments a method name to be called and any number
10982 of additional arguments that should be passed to the called method.
10983 The internals of the object get the needed changes so that CPAN.pm
10984 does not refuse to take the action. See also the section above on the
10985 C<force> and the C<fforce> pragma.
10986
10987 =item CPAN::Module::get()
10988
10989 Runs a get on the distribution associated with this module.
10990
10991 =item CPAN::Module::inst_file()
10992
10993 Returns the filename of the module found in @INC. The first file found
10994 is reported just like perl itself stops searching @INC when it finds a
10995 module.
10996
10997 =item CPAN::Module::available_file()
10998
10999 Returns the filename of the module found in PERL5LIB or @INC. The
11000 first file found is reported. The advantage of this method over
11001 C<inst_file> is that modules that have been tested but not yet
11002 installed are included because PERL5LIB keeps track of tested modules.
11003
11004 =item CPAN::Module::inst_version()
11005
11006 Returns the version number of the installed module in readable format.
11007
11008 =item CPAN::Module::available_version()
11009
11010 Returns the version number of the available module in readable format.
11011
11012 =item CPAN::Module::install()
11013
11014 Runs an C<install> on the distribution associated with this module.
11015
11016 =item CPAN::Module::look()
11017
11018 Changes to the directory where the distribution associated with this
11019 module has been unpacked and opens a subshell there. Exiting the
11020 subshell returns.
11021
11022 =item CPAN::Module::make()
11023
11024 Runs a C<make> on the distribution associated with this module.
11025
11026 =item CPAN::Module::manpage_headline()
11027
11028 If module is installed, peeks into the module's manpage, reads the
11029 headline and returns it. Moreover, if the module has been downloaded
11030 within this session, does the equivalent on the downloaded module even
11031 if it is not installed.
11032
11033 =item CPAN::Module::perldoc()
11034
11035 Runs a C<perldoc> on this module.
11036
11037 =item CPAN::Module::readme()
11038
11039 Runs a C<readme> on the distribution associated with this module.
11040
11041 =item CPAN::Module::test()
11042
11043 Runs a C<test> on the distribution associated with this module.
11044
11045 =item CPAN::Module::uptodate()
11046
11047 Returns 1 if the module is installed and up-to-date.
11048
11049 =item CPAN::Module::userid()
11050
11051 Returns the author's ID of the module.
11052
11053 =back
11054
11055 =head2 Cache Manager
11056
11057 Currently the cache manager only keeps track of the build directory
11058 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
11059 deletes complete directories below C<build_dir> as soon as the size of
11060 all directories there gets bigger than $CPAN::Config->{build_cache}
11061 (in MB). The contents of this cache may be used for later
11062 re-installations that you intend to do manually, but will never be
11063 trusted by CPAN itself. This is due to the fact that the user might
11064 use these directories for building modules on different architectures.
11065
11066 There is another directory ($CPAN::Config->{keep_source_where}) where
11067 the original distribution files are kept. This directory is not
11068 covered by the cache manager and must be controlled by the user. If
11069 you choose to have the same directory as build_dir and as
11070 keep_source_where directory, then your sources will be deleted with
11071 the same fifo mechanism.
11072
11073 =head2 Bundles
11074
11075 A bundle is just a perl module in the namespace Bundle:: that does not
11076 define any functions or methods. It usually only contains documentation.
11077
11078 It starts like a perl module with a package declaration and a $VERSION
11079 variable. After that the pod section looks like any other pod with the
11080 only difference being that I<one special pod section> exists starting with
11081 (verbatim):
11082
11083         =head1 CONTENTS
11084
11085 In this pod section each line obeys the format
11086
11087         Module_Name [Version_String] [- optional text]
11088
11089 The only required part is the first field, the name of a module
11090 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
11091 of the line is optional. The comment part is delimited by a dash just
11092 as in the man page header.
11093
11094 The distribution of a bundle should follow the same convention as
11095 other distributions.
11096
11097 Bundles are treated specially in the CPAN package. If you say 'install
11098 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
11099 the modules in the CONTENTS section of the pod. You can install your
11100 own Bundles locally by placing a conformant Bundle file somewhere into
11101 your @INC path. The autobundle() command which is available in the
11102 shell interface does that for you by including all currently installed
11103 modules in a snapshot bundle file.
11104
11105 =head1 PREREQUISITES
11106
11107 If you have a local mirror of CPAN and can access all files with
11108 "file:" URLs, then you only need a perl better than perl5.003 to run
11109 this module. Otherwise Net::FTP is strongly recommended. LWP may be
11110 required for non-UNIX systems or if your nearest CPAN site is
11111 associated with a URL that is not C<ftp:>.
11112
11113 If you have neither Net::FTP nor LWP, there is a fallback mechanism
11114 implemented for an external ftp command or for an external lynx
11115 command.
11116
11117 =head1 UTILITIES
11118
11119 =head2 Finding packages and VERSION
11120
11121 This module presumes that all packages on CPAN
11122
11123 =over 2
11124
11125 =item *
11126
11127 declare their $VERSION variable in an easy to parse manner. This
11128 prerequisite can hardly be relaxed because it consumes far too much
11129 memory to load all packages into the running program just to determine
11130 the $VERSION variable. Currently all programs that are dealing with
11131 version use something like this
11132
11133     perl -MExtUtils::MakeMaker -le \
11134         'print MM->parse_version(shift)' filename
11135
11136 If you are author of a package and wonder if your $VERSION can be
11137 parsed, please try the above method.
11138
11139 =item *
11140
11141 come as compressed or gzipped tarfiles or as zip files and contain a
11142 C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
11143 without much enthusiasm).
11144
11145 =back
11146
11147 =head2 Debugging
11148
11149 The debugging of this module is a bit complex, because we have
11150 interferences of the software producing the indices on CPAN, of the
11151 mirroring process on CPAN, of packaging, of configuration, of
11152 synchronicity, and of bugs within CPAN.pm.
11153
11154 For debugging the code of CPAN.pm itself in interactive mode some more
11155 or less useful debugging aid can be turned on for most packages within
11156 CPAN.pm with one of
11157
11158 =over 2
11159
11160 =item o debug package...
11161
11162 sets debug mode for packages.
11163
11164 =item o debug -package...
11165
11166 unsets debug mode for packages.
11167
11168 =item o debug all
11169
11170 turns debugging on for all packages.
11171
11172 =item o debug number
11173
11174 =back
11175
11176 which sets the debugging packages directly. Note that C<o debug 0>
11177 turns debugging off.
11178
11179 What seems quite a successful strategy is the combination of C<reload
11180 cpan> and the debugging switches. Add a new debug statement while
11181 running in the shell and then issue a C<reload cpan> and see the new
11182 debugging messages immediately without losing the current context.
11183
11184 C<o debug> without an argument lists the valid package names and the
11185 current set of packages in debugging mode. C<o debug> has built-in
11186 completion support.
11187
11188 For debugging of CPAN data there is the C<dump> command which takes
11189 the same arguments as make/test/install and outputs each object's
11190 Data::Dumper dump. If an argument looks like a perl variable and
11191 contains one of C<$>, C<@> or C<%>, it is eval()ed and fed to
11192 Data::Dumper directly.
11193
11194 =head2 Floppy, Zip, Offline Mode
11195
11196 CPAN.pm works nicely without network too. If you maintain machines
11197 that are not networked at all, you should consider working with file:
11198 URLs. Of course, you have to collect your modules somewhere first. So
11199 you might use CPAN.pm to put together all you need on a networked
11200 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
11201 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
11202 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
11203 with this floppy. See also below the paragraph about CD-ROM support.
11204
11205 =head2 Basic Utilities for Programmers
11206
11207 =over 2
11208
11209 =item has_inst($module)
11210
11211 Returns true if the module is installed. Used to load all modules into
11212 the running CPAN.pm which are considered optional. The config variable
11213 C<dontload_list> can be used to intercept the C<has_inst()> call such
11214 that an optional module is not loaded despite being available. For
11215 example the following command will prevent that C<YAML.pm> is being
11216 loaded:
11217
11218     cpan> o conf dontload_list push YAML
11219
11220 See the source for details.
11221
11222 =item has_usable($module)
11223
11224 Returns true if the module is installed and is in a usable state. Only
11225 useful for a handful of modules that are used internally. See the
11226 source for details.
11227
11228 =item instance($module)
11229
11230 The constructor for all the singletons used to represent modules,
11231 distributions, authors and bundles. If the object already exists, this
11232 method returns the object, otherwise it calls the constructor.
11233
11234 =back
11235
11236 =head1 SECURITY
11237
11238 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
11239 install foreign, unmasked, unsigned code on your machine. We compare
11240 to a checksum that comes from the net just as the distribution file
11241 itself. But we try to make it easy to add security on demand:
11242
11243 =head2 Cryptographically signed modules
11244
11245 Since release 1.77 CPAN.pm has been able to verify cryptographically
11246 signed module distributions using Module::Signature.  The CPAN modules
11247 can be signed by their authors, thus giving more security.  The simple
11248 unsigned MD5 checksums that were used before by CPAN protect mainly
11249 against accidental file corruption.
11250
11251 You will need to have Module::Signature installed, which in turn
11252 requires that you have at least one of Crypt::OpenPGP module or the
11253 command-line F<gpg> tool installed.
11254
11255 You will also need to be able to connect over the Internet to the public
11256 keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
11257
11258 The configuration parameter check_sigs is there to turn signature
11259 checking on or off.
11260
11261 =head1 EXPORT
11262
11263 Most functions in package CPAN are exported per default. The reason
11264 for this is that the primary use is intended for the cpan shell or for
11265 one-liners.
11266
11267 =head1 ENVIRONMENT
11268
11269 When the CPAN shell enters a subshell via the look command, it sets
11270 the environment CPAN_SHELL_LEVEL to 1 or increments it if it is
11271 already set.
11272
11273 When CPAN runs, it sets the environment variable PERL5_CPAN_IS_RUNNING.
11274
11275 When the config variable ftp_passive is set, all downloads will be run
11276 with the environment variable FTP_PASSIVE set to this value. This is
11277 in general a good idea as it influences both Net::FTP and LWP based
11278 connections. The same effect can be achieved by starting the cpan
11279 shell with this environment variable set. For Net::FTP alone, one can
11280 also always set passive mode by running libnetcfg.
11281
11282 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
11283
11284 Populating a freshly installed perl with my favorite modules is pretty
11285 easy if you maintain a private bundle definition file. To get a useful
11286 blueprint of a bundle definition file, the command autobundle can be used
11287 on the CPAN shell command line. This command writes a bundle definition
11288 file for all modules that are installed for the currently running perl
11289 interpreter. It's recommended to run this command only once and from then
11290 on maintain the file manually under a private name, say
11291 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
11292
11293     cpan> install Bundle::my_bundle
11294
11295 then answer a few questions and then go out for a coffee.
11296
11297 Maintaining a bundle definition file means keeping track of two
11298 things: dependencies and interactivity. CPAN.pm sometimes fails on
11299 calculating dependencies because not all modules define all MakeMaker
11300 attributes correctly, so a bundle definition file should specify
11301 prerequisites as early as possible. On the other hand, it's a bit
11302 annoying that many distributions need some interactive configuring. So
11303 what I try to accomplish in my private bundle file is to have the
11304 packages that need to be configured early in the file and the gentle
11305 ones later, so I can go out after a few minutes and leave CPAN.pm
11306 untended.
11307
11308 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
11309
11310 Thanks to Graham Barr for contributing the following paragraphs about
11311 the interaction between perl, and various firewall configurations. For
11312 further information on firewalls, it is recommended to consult the
11313 documentation that comes with the ncftp program. If you are unable to
11314 go through the firewall with a simple Perl setup, it is very likely
11315 that you can configure ncftp so that it works for your firewall.
11316
11317 =head2 Three basic types of firewalls
11318
11319 Firewalls can be categorized into three basic types.
11320
11321 =over 4
11322
11323 =item http firewall
11324
11325 This is where the firewall machine runs a web server and to access the
11326 outside world you must do it via the web server. If you set environment
11327 variables like http_proxy or ftp_proxy to a values beginning with http://
11328 or in your web browser you have to set proxy information then you know
11329 you are running an http firewall.
11330
11331 To access servers outside these types of firewalls with perl (even for
11332 ftp) you will need to use LWP.
11333
11334 =item ftp firewall
11335
11336 This where the firewall machine runs an ftp server. This kind of
11337 firewall will only let you access ftp servers outside the firewall.
11338 This is usually done by connecting to the firewall with ftp, then
11339 entering a username like "user@outside.host.com"
11340
11341 To access servers outside these type of firewalls with perl you
11342 will need to use Net::FTP.
11343
11344 =item One way visibility
11345
11346 I say one way visibility as these firewalls try to make themselves look
11347 invisible to the users inside the firewall. An FTP data connection is
11348 normally created by sending the remote server your IP address and then
11349 listening for the connection. But the remote server will not be able to
11350 connect to you because of the firewall. So for these types of firewall
11351 FTP connections need to be done in a passive mode.
11352
11353 There are two that I can think off.
11354
11355 =over 4
11356
11357 =item SOCKS
11358
11359 If you are using a SOCKS firewall you will need to compile perl and link
11360 it with the SOCKS library, this is what is normally called a 'socksified'
11361 perl. With this executable you will be able to connect to servers outside
11362 the firewall as if it is not there.
11363
11364 =item IP Masquerade
11365
11366 This is the firewall implemented in the Linux kernel, it allows you to
11367 hide a complete network behind one IP address. With this firewall no
11368 special compiling is needed as you can access hosts directly.
11369
11370 For accessing ftp servers behind such firewalls you usually need to
11371 set the environment variable C<FTP_PASSIVE> or the config variable
11372 ftp_passive to a true value.
11373
11374 =back
11375
11376 =back
11377
11378 =head2 Configuring lynx or ncftp for going through a firewall
11379
11380 If you can go through your firewall with e.g. lynx, presumably with a
11381 command such as
11382
11383     /usr/local/bin/lynx -pscott:tiger
11384
11385 then you would configure CPAN.pm with the command
11386
11387     o conf lynx "/usr/local/bin/lynx -pscott:tiger"
11388
11389 That's all. Similarly for ncftp or ftp, you would configure something
11390 like
11391
11392     o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
11393
11394 Your mileage may vary...
11395
11396 =head1 FAQ
11397
11398 =over 4
11399
11400 =item 1)
11401
11402 I installed a new version of module X but CPAN keeps saying,
11403 I have the old version installed
11404
11405 Most probably you B<do> have the old version installed. This can
11406 happen if a module installs itself into a different directory in the
11407 @INC path than it was previously installed. This is not really a
11408 CPAN.pm problem, you would have the same problem when installing the
11409 module manually. The easiest way to prevent this behaviour is to add
11410 the argument C<UNINST=1> to the C<make install> call, and that is why
11411 many people add this argument permanently by configuring
11412
11413   o conf make_install_arg UNINST=1
11414
11415 =item 2)
11416
11417 So why is UNINST=1 not the default?
11418
11419 Because there are people who have their precise expectations about who
11420 may install where in the @INC path and who uses which @INC array. In
11421 fine tuned environments C<UNINST=1> can cause damage.
11422
11423 =item 3)
11424
11425 I want to clean up my mess, and install a new perl along with
11426 all modules I have. How do I go about it?
11427
11428 Run the autobundle command for your old perl and optionally rename the
11429 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
11430 with the Configure option prefix, e.g.
11431
11432     ./Configure -Dprefix=/usr/local/perl-5.6.78.9
11433
11434 Install the bundle file you produced in the first step with something like
11435
11436     cpan> install Bundle::mybundle
11437
11438 and you're done.
11439
11440 =item 4)
11441
11442 When I install bundles or multiple modules with one command
11443 there is too much output to keep track of.
11444
11445 You may want to configure something like
11446
11447   o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
11448   o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
11449
11450 so that STDOUT is captured in a file for later inspection.
11451
11452
11453 =item 5)
11454
11455 I am not root, how can I install a module in a personal directory?
11456
11457 First of all, you will want to use your own configuration, not the one
11458 that your root user installed. If you do not have permission to write
11459 in the cpan directory that root has configured, you will be asked if
11460 you want to create your own config. Answering "yes" will bring you into
11461 CPAN's configuration stage, using the system config for all defaults except
11462 things that have to do with CPAN's work directory, saving your choices to
11463 your MyConfig.pm file.
11464
11465 You can also manually initiate this process with the following command:
11466
11467     % perl -MCPAN -e 'mkmyconfig'
11468
11469 or by running
11470
11471     mkmyconfig
11472
11473 from the CPAN shell.
11474
11475 You will most probably also want to configure something like this:
11476
11477   o conf makepl_arg "LIB=~/myperl/lib \
11478                     INSTALLMAN1DIR=~/myperl/man/man1 \
11479                     INSTALLMAN3DIR=~/myperl/man/man3 \
11480                     INSTALLSCRIPT=~/myperl/bin \
11481                     INSTALLBIN=~/myperl/bin"
11482
11483 and then (oh joy) the equivalent command for Module::Build.
11484
11485 You can make this setting permanent like all C<o conf> settings with
11486 C<o conf commit> or by setting C<auto_commit> beforehand.
11487
11488 You will have to add ~/myperl/man to the MANPATH environment variable
11489 and also tell your perl programs to look into ~/myperl/lib, e.g. by
11490 including
11491
11492   use lib "$ENV{HOME}/myperl/lib";
11493
11494 or setting the PERL5LIB environment variable.
11495
11496 While we're speaking about $ENV{HOME}, it might be worth mentioning,
11497 that for Windows we use the File::HomeDir module that provides an
11498 equivalent to the concept of the home directory on Unix.
11499
11500 Another thing you should bear in mind is that the UNINST parameter can
11501 be dnagerous when you are installing into a private area because you
11502 might accidentally remove modules that other people depend on that are
11503 not using the private area.
11504
11505 =item 6)
11506
11507 How to get a package, unwrap it, and make a change before building it?
11508
11509 Have a look at the C<look> (!) command.
11510
11511 =item 7)
11512
11513 I installed a Bundle and had a couple of fails. When I
11514 retried, everything resolved nicely. Can this be fixed to work
11515 on first try?
11516
11517 The reason for this is that CPAN does not know the dependencies of all
11518 modules when it starts out. To decide about the additional items to
11519 install, it just uses data found in the META.yml file or the generated
11520 Makefile. An undetected missing piece breaks the process. But it may
11521 well be that your Bundle installs some prerequisite later than some
11522 depending item and thus your second try is able to resolve everything.
11523 Please note, CPAN.pm does not know the dependency tree in advance and
11524 cannot sort the queue of things to install in a topologically correct
11525 order. It resolves perfectly well IF all modules declare the
11526 prerequisites correctly with the PREREQ_PM attribute to MakeMaker or
11527 the C<requires> stanza of Module::Build. For bundles which fail and
11528 you need to install often, it is recommended to sort the Bundle
11529 definition file manually.
11530
11531 =item 8)
11532
11533 In our intranet we have many modules for internal use. How
11534 can I integrate these modules with CPAN.pm but without uploading
11535 the modules to CPAN?
11536
11537 Have a look at the CPAN::Site module.
11538
11539 =item 9)
11540
11541 When I run CPAN's shell, I get an error message about things in my
11542 /etc/inputrc (or ~/.inputrc) file.
11543
11544 These are readline issues and can only be fixed by studying readline
11545 configuration on your architecture and adjusting the referenced file
11546 accordingly. Please make a backup of the /etc/inputrc or ~/.inputrc
11547 and edit them. Quite often harmless changes like uppercasing or
11548 lowercasing some arguments solves the problem.
11549
11550 =item 10)
11551
11552 Some authors have strange characters in their names.
11553
11554 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
11555 expecting ISO-8859-1 charset, a converter can be activated by setting
11556 term_is_latin to a true value in your config file. One way of doing so
11557 would be
11558
11559     cpan> o conf term_is_latin 1
11560
11561 If other charset support is needed, please file a bugreport against
11562 CPAN.pm at rt.cpan.org and describe your needs. Maybe we can extend
11563 the support or maybe UTF-8 terminals become widely available.
11564
11565 =item 11)
11566
11567 When an install fails for some reason and then I correct the error
11568 condition and retry, CPAN.pm refuses to install the module, saying
11569 C<Already tried without success>.
11570
11571 Use the force pragma like so
11572
11573   force install Foo::Bar
11574
11575 Or you can use
11576
11577   look Foo::Bar
11578
11579 and then 'make install' directly in the subshell.
11580
11581 =item 12)
11582
11583 How do I install a "DEVELOPER RELEASE" of a module?
11584
11585 By default, CPAN will install the latest non-developer release of a
11586 module. If you want to install a dev release, you have to specify the
11587 partial path starting with the author id to the tarball you wish to
11588 install, like so:
11589
11590     cpan> install KWILLIAMS/Module-Build-0.27_07.tar.gz
11591
11592 Note that you can use the C<ls> command to get this path listed.
11593
11594 =item 13)
11595
11596 How do I install a module and all its dependencies from the commandline,
11597 without being prompted for anything, despite my CPAN configuration
11598 (or lack thereof)?
11599
11600 CPAN uses ExtUtils::MakeMaker's prompt() function to ask its questions, so
11601 if you set the PERL_MM_USE_DEFAULT environment variable, you shouldn't be
11602 asked any questions at all (assuming the modules you are installing are
11603 nice about obeying that variable as well):
11604
11605     % PERL_MM_USE_DEFAULT=1 perl -MCPAN -e 'install My::Module'
11606
11607 =item 14)
11608
11609 How do I create a Module::Build based Build.PL derived from an
11610 ExtUtils::MakeMaker focused Makefile.PL?
11611
11612 http://search.cpan.org/search?query=Module::Build::Convert
11613
11614 http://www.refcnt.org/papers/module-build-convert
11615
11616 =item 15)
11617
11618 What's the best CPAN site for me?
11619
11620 The urllist config parameter is yours. You can add and remove sites at
11621 will. You should find out which sites have the best uptodateness,
11622 bandwidth, reliability, etc. and are topologically close to you. Some
11623 people prefer fast downloads, others uptodateness, others reliability.
11624 You decide which to try in which order.
11625
11626 Henk P. Penning maintains a site that collects data about CPAN sites:
11627
11628   http://www.cs.uu.nl/people/henkp/mirmon/cpan.html
11629
11630 =back
11631
11632 =head1 COMPATIBILITY
11633
11634 =head2 OLD PERL VERSIONS
11635
11636 CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted
11637 newer versions. It is getting more and more difficult to get the
11638 minimal prerequisites working on older perls. It is close to
11639 impossible to get the whole Bundle::CPAN working there. If you're in
11640 the position to have only these old versions, be advised that CPAN is
11641 designed to work fine without the Bundle::CPAN installed.
11642
11643 To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is
11644 compatible with ancient perls and that File::Temp is listed as a
11645 prerequisite but CPAN has reasonable workarounds if it is missing.
11646
11647 =head2 CPANPLUS
11648
11649 This module and its competitor, the CPANPLUS module, are both much
11650 cooler than the other. CPAN.pm is older. CPANPLUS was designed to be
11651 more modular but it was never tried to make it compatible with CPAN.pm.
11652
11653 =head1 SECURITY ADVICE
11654
11655 This software enables you to upgrade software on your computer and so
11656 is inherently dangerous because the newly installed software may
11657 contain bugs and may alter the way your computer works or even make it
11658 unusable. Please consider backing up your data before every upgrade.
11659
11660 =head1 BUGS
11661
11662 Please report bugs via http://rt.cpan.org/
11663
11664 Before submitting a bug, please make sure that the traditional method
11665 of building a Perl module package from a shell by following the
11666 installation instructions of that package still works in your
11667 environment.
11668
11669 =head1 AUTHOR
11670
11671 Andreas Koenig C<< <andk@cpan.org> >>
11672
11673 =head1 LICENSE
11674
11675 This program is free software; you can redistribute it and/or
11676 modify it under the same terms as Perl itself.
11677
11678 See L<http://www.perl.com/perl/misc/Artistic.html>
11679
11680 =head1 TRANSLATIONS
11681
11682 Kawai,Takanori provides a Japanese translation of this manpage at
11683 http://homepage3.nifty.com/hippo2000/perltips/CPAN.htm
11684
11685 =head1 SEE ALSO
11686
11687 cpan(1), CPAN::Nox(3pm), CPAN::Version(3pm)
11688
11689 =cut
11690
11691