lib/CPAN.pm

   1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
   2 use strict;
   3 package CPAN;
   4 $CPAN::VERSION = '1.88_77';
   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);
  38         }
  39     }
  40 }
  41 no lib ".";
  42
  43 require Mac::BuildTools if $^O eq 'MacOS';
  44 $ENV{PERL5_CPAN_IS_RUNNING}=1;
  45
  46 END { $CPAN::End++; &cleanup; }
  47
  48 $CPAN::Signal ||= 0;
  49 $CPAN::Frontend ||= "CPAN::Shell";
  50 unless (@CPAN::Defaultsites){
  51     @CPAN::Defaultsites = map {
  52         CPAN::URL->new(TEXT => $_, FROM => "DEF")
  53     }
  54         "http://www.perl.org/CPAN/",
  55             "ftp://ftp.perl.org/pub/CPAN/";
  56 }
  57 # $CPAN::iCwd (i for initial) is going to be initialized during find_perl
  58 $CPAN::Perl ||= CPAN::find_perl();
  59 $CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?";
  60 $CPAN::Defaultrecent ||= "http://search.cpan.org/recent";
  61
  62 # our globals are getting a mess
  63 use vars qw(
  64             $AUTOLOAD
  65             $Be_Silent
  66             $CONFIG_DIRTY
  67             $Defaultdocs
  68             $Defaultrecent
  69             $Frontend
  70             $GOTOSHELL
  71             $HAS_USABLE
  72             $Have_warned
  73             $MAX_RECURSION
  74             $META
  75             $RUN_DEGRADED
  76             $Signal
  77             $SQLite
  78             $Suppress_readline
  79             $VERSION
  80             $autoload_recursion
  81             $term
  82             @Defaultsites
  83             @EXPORT
  84            );
  85
  86 $MAX_RECURSION = 32;
  87
  88 @CPAN::ISA = qw(CPAN::Debug Exporter);
  89
  90 # note that these functions live in CPAN::Shell and get executed via
  91 # AUTOLOAD when called directly
  92 @EXPORT = qw(
  93              autobundle
  94              bundle
  95              clean
  96              cvs_import
  97              expand
  98              force
  99              fforce
 100              get
 101              install
 102              install_tested
 103              is_tested
 104              make
 105              mkmyconfig
 106              notest
 107              perldoc
 108              readme
 109              recent
 110              recompile
 111              report
 112              shell
 113              test
 114              upgrade
 115             );
 116
 117 sub soft_chdir_with_alternatives ($);
 118
 119 {
 120     $autoload_recursion ||= 0;
 121
 122     #-> sub CPAN::AUTOLOAD ;
 123     sub AUTOLOAD {
 124         $autoload_recursion++;
 125         my($l) = $AUTOLOAD;
 126         $l =~ s/.*:://;
 127         if ($CPAN::Signal) {
 128             warn "Refusing to autoload '$l' while signal pending";
 129             $autoload_recursion--;
 130             return;
 131         }
 132         if ($autoload_recursion > 1) {
 133             my $fullcommand = join " ", map { "'$_'" } $l, @_;
 134             warn "Refusing to autoload $fullcommand in recursion\n";
 135             $autoload_recursion--;
 136             return;
 137         }
 138         my(%export);
 139         @export{@EXPORT} = '';
 140         CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 141         if (exists $export{$l}){
 142             CPAN::Shell->$l(@_);
 143         } else {
 144             die(qq{Unknown CPAN command "$AUTOLOAD". }.
 145                 qq{Type ? for help.\n});
 146         }
 147         $autoload_recursion--;
 148     }
 149 }
 150
 151 #-> sub CPAN::shell ;
 152 sub shell {
 153     my($self) = @_;
 154     $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
 155     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 156
 157     my $oprompt = shift || CPAN::Prompt->new;
 158     my $prompt = $oprompt;
 159     my $commandline = shift || "";
 160     $CPAN::CurrentCommandId ||= 1;
 161
 162     local($^W) = 1;
 163     unless ($Suppress_readline) {
 164         require Term::ReadLine;
 165         if (! $term
 166             or
 167             $term->ReadLine eq "Term::ReadLine::Stub"
 168            ) {
 169             $term = Term::ReadLine->new('CPAN Monitor');
 170         }
 171         if ($term->ReadLine eq "Term::ReadLine::Gnu") {
 172             my $attribs = $term->Attribs;
 173              $attribs->{attempted_completion_function} = sub {
 174                  &CPAN::Complete::gnu_cpl;
 175              }
 176         } else {
 177             $readline::rl_completion_function =
 178                 $readline::rl_completion_function = 'CPAN::Complete::cpl';
 179         }
 180         if (my $histfile = $CPAN::Config->{'histfile'}) {{
 181             unless ($term->can("AddHistory")) {
 182                 $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
 183                 last;
 184             }
 185             $META->readhist($term,$histfile);
 186         }}
 187         for ($CPAN::Config->{term_ornaments}) { # alias
 188             local $Term::ReadLine::termcap_nowarn = 1;
 189             $term->ornaments($_) if defined;
 190         }
 191         # $term->OUT is autoflushed anyway
 192         my $odef = select STDERR;
 193         $| = 1;
 194         select STDOUT;
 195         $| = 1;
 196         select $odef;
 197     }
 198
 199     $META->checklock();
 200     my @cwd = grep { defined $_ and length $_ }
 201         CPAN::anycwd(),
 202               File::Spec->can("tmpdir") ? File::Spec->tmpdir() : (),
 203                     File::Spec->rootdir();
 204     my $try_detect_readline;
 205     $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
 206     my $rl_avail = $Suppress_readline ? "suppressed" :
 207         ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
 208             "available (try 'install Bundle::CPAN')";
 209
 210     unless ($CPAN::Config->{'inhibit_startup_message'}){
 211         $CPAN::Frontend->myprint(
 212                                  sprintf qq{
 213 cpan shell -- CPAN exploration and modules installation (v%s)
 214 ReadLine support %s
 215
 216 },
 217                                  $CPAN::VERSION,
 218                                  $rl_avail
 219                                 )
 220     }
 221     my($continuation) = "";
 222     my $last_term_ornaments;
 223   SHELLCOMMAND: while () {
 224         if ($Suppress_readline) {
 225             print $prompt;
 226             last SHELLCOMMAND unless defined ($_ = <> );
 227             chomp;
 228         } else {
 229             last SHELLCOMMAND unless
 230                 defined ($_ = $term->readline($prompt, $commandline));
 231         }
 232         $_ = "$continuation$_" if $continuation;
 233         s/^\s+//;
 234         next SHELLCOMMAND if /^$/;
 235         $_ = 'h' if /^\s*\?/;
 236         if (/^(?:q(?:uit)?|bye|exit)$/i) {
 237             last SHELLCOMMAND;
 238         } elsif (s/\\$//s) {
 239             chomp;
 240             $continuation = $_;
 241             $prompt = "    > ";
 242         } elsif (/^\!/) {
 243             s/^\!//;
 244             my($eval) = $_;
 245             package CPAN::Eval;
 246             use strict;
 247             use vars qw($import_done);
 248             CPAN->import(':DEFAULT') unless $import_done++;
 249             CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
 250             eval($eval);
 251             warn $@ if $@;
 252             $continuation = "";
 253             $prompt = $oprompt;
 254         } elsif (/./) {
 255             my(@line);
 256             eval { @line = Text::ParseWords::shellwords($_) };
 257             warn($@), next SHELLCOMMAND if $@;
 258             warn("Text::Parsewords could not parse the line [$_]"),
 259                 next SHELLCOMMAND unless @line;
 260             $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
 261             my $command = shift @line;
 262             eval { CPAN::Shell->$command(@line) };
 263             if ($@ && "$@" =~ /\S/){
 264                 require Carp;
 265                 Carp::cluck("Catching error: '$@'");
 266             }
 267             if ($command =~ /^(make|test|install|ff?orce|notest|clean|report|upgrade)$/) {
 268                 CPAN::Shell->failed($CPAN::CurrentCommandId,1);
 269             }
 270             soft_chdir_with_alternatives(\@cwd);
 271             $CPAN::Frontend->myprint("\n");
 272             $continuation = "";
 273             $CPAN::CurrentCommandId++;
 274             $prompt = $oprompt;
 275         }
 276     } continue {
 277       $commandline = ""; # I do want to be able to pass a default to
 278                          # shell, but on the second command I see no
 279                          # use in that
 280       $Signal=0;
 281       CPAN::Queue->nullify_queue;
 282       if ($try_detect_readline) {
 283         if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
 284             ||
 285             $CPAN::META->has_inst("Term::ReadLine::Perl")
 286            ) {
 287             delete $INC{"Term/ReadLine.pm"};
 288             my $redef = 0;
 289             local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
 290             require Term::ReadLine;
 291             $CPAN::Frontend->myprint("\n$redef subroutines in ".
 292                                      "Term::ReadLine redefined\n");
 293             $GOTOSHELL = 1;
 294         }
 295       }
 296       if ($term and $term->can("ornaments")) {
 297           for ($CPAN::Config->{term_ornaments}) { # alias
 298               if (defined $_) {
 299                   if (not defined $last_term_ornaments
 300                       or $_ != $last_term_ornaments
 301                      ) {
 302                       local $Term::ReadLine::termcap_nowarn = 1;
 303                       $term->ornaments($_);
 304                       $last_term_ornaments = $_;
 305                   }
 306               } else {
 307                   undef $last_term_ornaments;
 308               }
 309           }
 310       }
 311       for my $class (qw(Module Distribution)) {
 312           # again unsafe meta access?
 313           for my $dm (keys %{$CPAN::META->{readwrite}{"CPAN::$class"}}) {
 314               next unless $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
 315               CPAN->debug("BUG: $class '$dm' was in command state, resetting");
 316               delete $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
 317           }
 318       }
 319       if ($GOTOSHELL) {
 320           $GOTOSHELL = 0; # not too often
 321           $META->savehist if $CPAN::term && $CPAN::term->can("GetHistory");
 322           @_ = ($oprompt,"");
 323           goto &shell;
 324       }
 325     }
 326     soft_chdir_with_alternatives(\@cwd);
 327 }
 328
 329 sub soft_chdir_with_alternatives ($) {
 330     my($cwd) = @_;
 331     unless (@$cwd) {
 332         my $root = File::Spec->rootdir();
 333         $CPAN::Frontend->mywarn(qq{Warning: no good directory to chdir to!
 334 Trying '$root' as temporary haven.
 335 });
 336         push @$cwd, $root;
 337     }
 338     while () {
 339         if (chdir $cwd->[0]) {
 340             return;
 341         } else {
 342             if (@$cwd>1) {
 343                 $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $!
 344 Trying to chdir to "$cwd->[1]" instead.
 345 });
 346                 shift @$cwd;
 347             } else {
 348                 $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!});
 349             }
 350         }
 351     }
 352 }
 353
 354 sub _yaml_module () {
 355     my $yaml_module = $CPAN::Config->{yaml_module} || "YAML";
 356     if (
 357         $yaml_module ne "YAML"
 358         &&
 359         !$CPAN::META->has_inst($yaml_module)
 360        ) {
 361         # $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back to 'YAML'\n");
 362         $yaml_module = "YAML";
 363     }
 364     return $yaml_module;
 365 }
 366
 367 # CPAN::_yaml_loadfile
 368 sub _yaml_loadfile {
 369     my($self,$local_file) = @_;
 370     return +[] unless -s $local_file;
 371     my $yaml_module = _yaml_module;
 372     if ($CPAN::META->has_inst($yaml_module)) {
 373         my $code;
 374         if ($code = UNIVERSAL::can($yaml_module, "LoadFile")) {
 375             my @yaml;
 376             eval { @yaml = $code->($local_file); };
 377             if ($@) {
 378                 # this shall not be done by the frontend
 379                 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
 380             }
 381             return \@yaml;
 382         } elsif ($code = UNIVERSAL::can($yaml_module, "Load")) {
 383             local *FH;
 384             open FH, $local_file or die "Could not open '$local_file': $!";
 385             local $/;
 386             my $ystream = <FH>;
 387             my @yaml;
 388             eval { @yaml = $code->($ystream); };
 389             if ($@) {
 390                 # this shall not be done by the frontend
 391                 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
 392             }
 393             return \@yaml;
 394         }
 395     } else {
 396         # this shall not be done by the frontend
 397         die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "parse");
 398     }
 399     return +[];
 400 }
 401
 402 # CPAN::_yaml_dumpfile
 403 sub _yaml_dumpfile {
 404     my($self,$local_file,@what) = @_;
 405     my $yaml_module = _yaml_module;
 406     if ($CPAN::META->has_inst($yaml_module)) {
 407         my $code;
 408         if (UNIVERSAL::isa($local_file, "FileHandle")) {
 409             $code = UNIVERSAL::can($yaml_module, "Dump");
 410             eval { print $local_file $code->(@what) };
 411         } elsif ($code = UNIVERSAL::can($yaml_module, "DumpFile")) {
 412             eval { $code->($local_file,@what); };
 413         } elsif ($code = UNIVERSAL::can($yaml_module, "Dump")) {
 414             local *FH;
 415             open FH, ">$local_file" or die "Could not open '$local_file': $!";
 416             print FH $code->(@what);
 417         }
 418         if ($@) {
 419             die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"dump",$@);
 420         }
 421     } else {
 422         if (UNIVERSAL::isa($local_file, "FileHandle")) {
 423             # I think this case does not justify a warning at all
 424         } else {
 425             die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "dump");
 426         }
 427     }
 428 }
 429
 430 sub _init_sqlite () {
 431     unless ($CPAN::META->has_inst("CPAN::SQLite")) {
 432         $CPAN::Frontend->mywarn(qq{CPAN::SQLite not installed, trying to work without\n})
 433             unless $Have_warned->{"CPAN::SQLite"}++;
 434         return;
 435     }
 436     require CPAN::SQLite::META; # not needed since CVS version of 2006-12-17
 437     $CPAN::SQLite ||= CPAN::SQLite::META->new($CPAN::META);
 438 }
 439
 440 {
 441     my $negative_cache = {};
 442     sub _sqlite_running {
 443         if ($negative_cache->{time} && time < $negative_cache->{time} + 60) {
 444             # need to cache the result, otherwise too slow
 445             return $negative_cache->{fact};
 446         } else {
 447             $negative_cache = {}; # reset
 448         }
 449         my $ret = $CPAN::Config->{use_sqlite} && ($CPAN::SQLite || _init_sqlite());
 450         return $ret if $ret; # fast anyway
 451         $negative_cache->{time} = time;
 452         return $negative_cache->{fact} = $ret;
 453     }
 454 }
 455
 456 package CPAN::CacheMgr;
 457 use strict;
 458 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
 459 use File::Find;
 460
 461 package CPAN::FTP;
 462 use strict;
 463 use Fcntl qw(:flock);
 464 use vars qw($Ua $Thesite $ThesiteURL $Themethod);
 465 @CPAN::FTP::ISA = qw(CPAN::Debug);
 466
 467 package CPAN::LWP::UserAgent;
 468 use strict;
 469 use vars qw(@ISA $USER $PASSWD $SETUPDONE);
 470 # we delay requiring LWP::UserAgent and setting up inheritance until we need it
 471
 472 package CPAN::Complete;
 473 use strict;
 474 @CPAN::Complete::ISA = qw(CPAN::Debug);
 475 # Q: where is the "How do I add a new command" HOWTO?
 476 # A: svn diff -r 1048:1049 where andk added the report command
 477 @CPAN::Complete::COMMANDS = sort qw(
 478                                     ! a b d h i m o q r u
 479                                     autobundle
 480                                     clean
 481                                     cvs_import
 482                                     dump
 483                                     failed
 484                                     force
 485                                     fforce
 486                                     hosts
 487                                     install
 488                                     install_tested
 489                                     is_tested
 490                                     look
 491                                     ls
 492                                     make
 493                                     mkmyconfig
 494                                     notest
 495                                     perldoc
 496                                     readme
 497                                     recent
 498                                     recompile
 499                                     reload
 500                                     report
 501                                     scripts
 502                                     test
 503                                     upgrade
 504 );
 505
 506 package CPAN::Index;
 507 use strict;
 508 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED);
 509 @CPAN::Index::ISA = qw(CPAN::Debug);
 510 $LAST_TIME ||= 0;
 511 $DATE_OF_03 ||= 0;
 512 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
 513 sub PROTOCOL { 2.0 }
 514
 515 package CPAN::InfoObj;
 516 use strict;
 517 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
 518
 519 package CPAN::Author;
 520 use strict;
 521 @CPAN::Author::ISA = qw(CPAN::InfoObj);
 522
 523 package CPAN::Distribution;
 524 use strict;
 525 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
 526
 527 package CPAN::Bundle;
 528 use strict;
 529 @CPAN::Bundle::ISA = qw(CPAN::Module);
 530
 531 package CPAN::Module;
 532 use strict;
 533 @CPAN::Module::ISA = qw(CPAN::InfoObj);
 534
 535 package CPAN::Exception::RecursiveDependency;
 536 use strict;
 537 use overload '""' => "as_string";
 538
 539 # a module sees its distribution (no version)
 540 # a distribution sees its prereqs (which are module names) (usually with versions)
 541 # a bundle sees its module names and/or its distributions (no version)
 542
 543 sub new {
 544     my($class) = shift;
 545     my($deps) = shift;
 546     my @deps;
 547     my %seen;
 548     for my $dep (@$deps) {
 549         push @deps, $dep;
 550         last if $seen{$dep}++;
 551     }
 552     bless { deps => \@deps }, $class;
 553 }
 554
 555 sub as_string {
 556     my($self) = shift;
 557     "\nRecursive dependency detected:\n    " .
 558         join("\n => ", @{$self->{deps}}) .
 559             ".\nCannot continue.\n";
 560 }
 561
 562 package CPAN::Exception::yaml_not_installed;
 563 use strict;
 564 use overload '""' => "as_string";
 565
 566 sub new {
 567     my($class,$module,$file,$during) = @_;
 568     bless { module => $module, file => $file, during => $during }, $class;
 569 }
 570
 571 sub as_string {
 572     my($self) = shift;
 573     "'$self->{module}' not installed, cannot $self->{during} '$self->{file}'\n";
 574 }
 575
 576 package CPAN::Exception::yaml_process_error;
 577 use strict;
 578 use overload '""' => "as_string";
 579
 580 sub new {
 581     my($class,$module,$file,$during,$error) = shift;
 582     bless { module => $module,
 583             file => $file,
 584             during => $during,
 585             error => $error }, $class;
 586 }
 587
 588 sub as_string {
 589     my($self) = shift;
 590     "Alert: While trying to $self->{during} YAML file\n".
 591         "  $self->{file}\n".
 592             "with '$self->{module}' the following error was encountered:\n".
 593                 "  $self->{error}\n";
 594 }
 595
 596 package CPAN::Prompt; use overload '""' => "as_string";
 597 use vars qw($prompt);
 598 $prompt = "cpan> ";
 599 $CPAN::CurrentCommandId ||= 0;
 600 sub new {
 601     bless {}, shift;
 602 }
 603 sub as_string {
 604     my $word = "cpan";
 605     unless ($CPAN::META->{LOCK}) {
 606         $word = "nolock_cpan";
 607     }
 608     if ($CPAN::Config->{commandnumber_in_prompt}) {
 609         sprintf "$word\[%d]> ", $CPAN::CurrentCommandId;
 610     } else {
 611         "$word> ";
 612     }
 613 }
 614
 615 package CPAN::URL; use overload '""' => "as_string", fallback => 1;
 616 # accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist),
 617 # planned are things like age or quality
 618 sub new {
 619     my($class,%args) = @_;
 620     bless {
 621            %args
 622           }, $class;
 623 }
 624 sub as_string {
 625     my($self) = @_;
 626     $self->text;
 627 }
 628 sub text {
 629     my($self,$set) = @_;
 630     if (defined $set) {
 631         $self->{TEXT} = $set;
 632     }
 633     $self->{TEXT};
 634 }
 635
 636 package CPAN::Distrostatus;
 637 use overload '""' => "as_string",
 638     fallback => 1;
 639 sub new {
 640     my($class,$arg) = @_;
 641     bless {
 642            TEXT => $arg,
 643            FAILED => substr($arg,0,2) eq "NO",
 644            COMMANDID => $CPAN::CurrentCommandId,
 645            TIME => time,
 646           }, $class;
 647 }
 648 sub commandid { shift->{COMMANDID} }
 649 sub failed { shift->{FAILED} }
 650 sub text {
 651     my($self,$set) = @_;
 652     if (defined $set) {
 653         $self->{TEXT} = $set;
 654     }
 655     $self->{TEXT};
 656 }
 657 sub as_string {
 658     my($self) = @_;
 659     $self->text;
 660 }
 661
 662 package CPAN::Shell;
 663 use strict;
 664 use vars qw(
 665             $ADVANCED_QUERY
 666             $AUTOLOAD
 667             $COLOR_REGISTERED
 668             $autoload_recursion
 669             $reload
 670             @ISA
 671            );
 672 @CPAN::Shell::ISA = qw(CPAN::Debug);
 673 $COLOR_REGISTERED ||= 0;
 674
 675 {
 676     $autoload_recursion   ||= 0;
 677
 678     #-> sub CPAN::Shell::AUTOLOAD ;
 679     sub AUTOLOAD {
 680         $autoload_recursion++;
 681         my($l) = $AUTOLOAD;
 682         my $class = shift(@_);
 683         # warn "autoload[$l] class[$class]";
 684         $l =~ s/.*:://;
 685         if ($CPAN::Signal) {
 686             warn "Refusing to autoload '$l' while signal pending";
 687             $autoload_recursion--;
 688             return;
 689         }
 690         if ($autoload_recursion > 1) {
 691             my $fullcommand = join " ", map { "'$_'" } $l, @_;
 692             warn "Refusing to autoload $fullcommand in recursion\n";
 693             $autoload_recursion--;
 694             return;
 695         }
 696         if ($l =~ /^w/) {
 697             # XXX needs to be reconsidered
 698             if ($CPAN::META->has_inst('CPAN::WAIT')) {
 699                 CPAN::WAIT->$l(@_);
 700             } else {
 701                 $CPAN::Frontend->mywarn(qq{
 702 Commands starting with "w" require CPAN::WAIT to be installed.
 703 Please consider installing CPAN::WAIT to use the fulltext index.
 704 For this you just need to type
 705     install CPAN::WAIT
 706 });
 707             }
 708         } else {
 709             $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }.
 710                                     qq{Type ? for help.
 711 });
 712         }
 713         $autoload_recursion--;
 714     }
 715 }
 716
 717 package CPAN;
 718 use strict;
 719
 720 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
 721
 722 # from here on only subs.
 723 ################################################################################
 724
 725 sub _perl_fingerprint {
 726     my($self,$other_fingerprint) = @_;
 727     my $dll = eval {OS2::DLLname()};
 728     my $mtime_dll = 0;
 729     if (defined $dll) {
 730         $mtime_dll = (-f $dll ? (stat(_))[9] : '-1');
 731     }
 732     my $mtime_perl = (-f $^X ? (stat(_))[9] : '-1');
 733     my $this_fingerprint = {
 734                             '$^X' => $^X,
 735                             sitearchexp => $Config::Config{sitearchexp},
 736                             'mtime_$^X' => $mtime_perl,
 737                             'mtime_dll' => $mtime_dll,
 738                            };
 739     if ($other_fingerprint) {
 740         if (exists $other_fingerprint->{'stat($^X)'}) { # repair fp from rev. 1.88_57
 741             $other_fingerprint->{'mtime_$^X'} = $other_fingerprint->{'stat($^X)'}[9];
 742         }
 743         # mandatory keys since 1.88_57
 744         for my $key (qw($^X sitearchexp mtime_dll mtime_$^X)) {
 745             return unless $other_fingerprint->{$key} eq $this_fingerprint->{$key};
 746         }
 747         return 1;
 748     } else {
 749         return $this_fingerprint;
 750     }
 751 }
 752
 753 sub suggest_myconfig () {
 754   SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) {
 755         $CPAN::Frontend->myprint("You don't seem to have a user ".
 756                                  "configuration (MyConfig.pm) yet.\n");
 757         my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ".
 758                                               "user configuration now? (Y/n)",
 759                                               "yes");
 760         if($new =~ m{^y}i) {
 761             CPAN::Shell->mkmyconfig();
 762             return &checklock;
 763         } else {
 764             $CPAN::Frontend->mydie("OK, giving up.");
 765         }
 766     }
 767 }
 768
 769 #-> sub CPAN::all_objects ;
 770 sub all_objects {
 771     my($mgr,$class) = @_;
 772     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 773     CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
 774     CPAN::Index->reload;
 775     values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
 776 }
 777
 778 # Called by shell, not in batch mode. In batch mode I see no risk in
 779 # having many processes updating something as installations are
 780 # continually checked at runtime. In shell mode I suspect it is
 781 # unintentional to open more than one shell at a time
 782
 783 #-> sub CPAN::checklock ;
 784 sub checklock {
 785     my($self) = @_;
 786     my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
 787     if (-f $lockfile && -M _ > 0) {
 788         my $fh = FileHandle->new($lockfile) or
 789             $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
 790         my $otherpid  = <$fh>;
 791         my $otherhost = <$fh>;
 792         $fh->close;
 793         if (defined $otherpid && $otherpid) {
 794             chomp $otherpid;
 795         }
 796         if (defined $otherhost && $otherhost) {
 797             chomp $otherhost;
 798         }
 799         my $thishost  = hostname();
 800         if (defined $otherhost && defined $thishost &&
 801             $otherhost ne '' && $thishost ne '' &&
 802             $otherhost ne $thishost) {
 803             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
 804                                            "reports other host $otherhost and other ".
 805                                            "process $otherpid.\n".
 806                                            "Cannot proceed.\n"));
 807         } elsif ($RUN_DEGRADED) {
 808             $CPAN::Frontend->mywarn("Running in degraded mode (experimental)\n");
 809         } elsif (defined $otherpid && $otherpid) {
 810             return if $$ == $otherpid; # should never happen
 811             $CPAN::Frontend->mywarn(
 812                                     qq{
 813 There seems to be running another CPAN process (pid $otherpid).  Contacting...
 814 });
 815             if (kill 0, $otherpid) {
 816                 $CPAN::Frontend->mywarn(qq{Other job is running.\n});
 817                 my($ans) =
 818                     CPAN::Shell::colorable_makemaker_prompt
 819                         (qq{Shall I try to run in degraded }.
 820                          qq{mode? (Y/n)},"y");
 821                 if ($ans =~ /^y/i) {
 822                     $CPAN::Frontend->mywarn("Running in degraded mode (experimental).
 823 Please report if something unexpected happens\n");
 824                     $RUN_DEGRADED = 1;
 825                     for ($CPAN::Config) {
 826                         # XXX
 827                         # $_->{build_dir_reuse} = 0; # 2006-11-17 akoenig Why was that?
 828                         $_->{commandnumber_in_prompt} = 0; # visibility
 829                         $_->{histfile} = "";               # who should win otherwise?
 830                         $_->{cache_metadata} = 0;          # better would be a lock?
 831                         $_->{use_sqlite} = 0;              # better would be a write lock!
 832                     }
 833                 } else {
 834                     $CPAN::Frontend->mydie("
 835 You may want to kill the other job and delete the lockfile. On UNIX try:
 836     kill $otherpid
 837     rm $lockfile
 838 ");
 839                 }
 840             } elsif (-w $lockfile) {
 841                 my($ans) =
 842                     CPAN::Shell::colorable_makemaker_prompt
 843                         (qq{Other job not responding. Shall I overwrite }.
 844                          qq{the lockfile '$lockfile'? (Y/n)},"y");
 845                 $CPAN::Frontend->myexit("Ok, bye\n")
 846                     unless $ans =~ /^y/i;
 847             } else {
 848                 Carp::croak(
 849                             qq{Lockfile '$lockfile' not writeable by you. }.
 850                             qq{Cannot proceed.\n}.
 851                             qq{    On UNIX try:\n}.
 852                             qq{    rm '$lockfile'\n}.
 853                             qq{  and then rerun us.\n}
 854                            );
 855             }
 856         } else {
 857             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Found invalid lockfile ".
 858                                            "'$lockfile', please remove. Cannot proceed.\n"));
 859         }
 860     }
 861     my $dotcpan = $CPAN::Config->{cpan_home};
 862     eval { File::Path::mkpath($dotcpan);};
 863     if ($@) {
 864         # A special case at least for Jarkko.
 865         my $firsterror = $@;
 866         my $seconderror;
 867         my $symlinkcpan;
 868         if (-l $dotcpan) {
 869             $symlinkcpan = readlink $dotcpan;
 870             die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
 871             eval { File::Path::mkpath($symlinkcpan); };
 872             if ($@) {
 873                 $seconderror = $@;
 874             } else {
 875                 $CPAN::Frontend->mywarn(qq{
 876 Working directory $symlinkcpan created.
 877 });
 878             }
 879         }
 880         unless (-d $dotcpan) {
 881             my $mess = qq{
 882 Your configuration suggests "$dotcpan" as your
 883 CPAN.pm working directory. I could not create this directory due
 884 to this error: $firsterror\n};
 885             $mess .= qq{
 886 As "$dotcpan" is a symlink to "$symlinkcpan",
 887 I tried to create that, but I failed with this error: $seconderror
 888 } if $seconderror;
 889             $mess .= qq{
 890 Please make sure the directory exists and is writable.
 891 };
 892             $CPAN::Frontend->myprint($mess);
 893             return suggest_myconfig;
 894         }
 895     } # $@ after eval mkpath $dotcpan
 896     if (0) { # to test what happens when a race condition occurs
 897         for (reverse 1..10) {
 898             print $_, "\n";
 899             sleep 1;
 900         }
 901     }
 902     # locking
 903     if (!$RUN_DEGRADED && !$self->{LOCKFH}) {
 904         my $fh;
 905         unless ($fh = FileHandle->new("+>>$lockfile")) {
 906             if ($! =~ /Permission/) {
 907                 $CPAN::Frontend->myprint(qq{
 908
 909 Your configuration suggests that CPAN.pm should use a working
 910 directory of
 911     $CPAN::Config->{cpan_home}
 912 Unfortunately we could not create the lock file
 913     $lockfile
 914 due to permission problems.
 915
 916 Please make sure that the configuration variable
 917     \$CPAN::Config->{cpan_home}
 918 points to a directory where you can write a .lock file. You can set
 919 this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
 920 \@INC path;
 921 });
 922                 return suggest_myconfig;
 923             }
 924         }
 925         my $sleep = 1;
 926         while (!flock $fh, LOCK_EX|LOCK_NB) {
 927             if ($sleep>10) {
 928                 $CPAN::Frontend->mydie("Giving up\n");
 929             }
 930             $CPAN::Frontend->mysleep($sleep++);
 931             $CPAN::Frontend->mywarn("Could not lock lockfile with flock: $!; retrying\n");
 932         }
 933
 934         seek $fh, 0, 0;
 935         truncate $fh, 0;
 936         $fh->print($$, "\n");
 937         $fh->print(hostname(), "\n");
 938         $self->{LOCK} = $lockfile;
 939         $self->{LOCKFH} = $fh;
 940     }
 941     $SIG{TERM} = sub {
 942         my $sig = shift;
 943         &cleanup;
 944         $CPAN::Frontend->mydie("Got SIG$sig, leaving");
 945     };
 946     $SIG{INT} = sub {
 947       # no blocks!!!
 948         my $sig = shift;
 949         &cleanup if $Signal;
 950         die "Got yet another signal" if $Signal > 1;
 951         $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal;
 952         $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n");
 953         $Signal++;
 954     };
 955
 956 #       From: Larry Wall <larry@wall.org>
 957 #       Subject: Re: deprecating SIGDIE
 958 #       To: perl5-porters@perl.org
 959 #       Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
 960 #
 961 #       The original intent of __DIE__ was only to allow you to substitute one
 962 #       kind of death for another on an application-wide basis without respect
 963 #       to whether you were in an eval or not.  As a global backstop, it should
 964 #       not be used any more lightly (or any more heavily :-) than class
 965 #       UNIVERSAL.  Any attempt to build a general exception model on it should
 966 #       be politely squashed.  Any bug that causes every eval {} to have to be
 967 #       modified should be not so politely squashed.
 968 #
 969 #       Those are my current opinions.  It is also my optinion that polite
 970 #       arguments degenerate to personal arguments far too frequently, and that
 971 #       when they do, it's because both people wanted it to, or at least didn't
 972 #       sufficiently want it not to.
 973 #
 974 #       Larry
 975
 976     # global backstop to cleanup if we should really die
 977     $SIG{__DIE__} = \&cleanup;
 978     $self->debug("Signal handler set.") if $CPAN::DEBUG;
 979 }
 980
 981 #-> sub CPAN::DESTROY ;
 982 sub DESTROY {
 983     &cleanup; # need an eval?
 984 }
 985
 986 #-> sub CPAN::anycwd ;
 987 sub anycwd () {
 988     my $getcwd;
 989     $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
 990     CPAN->$getcwd();
 991 }
 992
 993 #-> sub CPAN::cwd ;
 994 sub cwd {Cwd::cwd();}
 995
 996 #-> sub CPAN::getcwd ;
 997 sub getcwd {Cwd::getcwd();}
 998
 999 #-> sub CPAN::fastcwd ;
1000 sub fastcwd {Cwd::fastcwd();}
1001
1002 #-> sub CPAN::backtickcwd ;
1003 sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
1004
1005 #-> sub CPAN::find_perl ;
1006 sub find_perl {
1007     my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
1008     my $pwd  = $CPAN::iCwd = CPAN::anycwd();
1009     my $candidate = File::Spec->catfile($pwd,$^X);
1010     $perl ||= $candidate if MM->maybe_command($candidate);
1011
1012     unless ($perl) {
1013         my ($component,$perl_name);
1014       DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
1015             PATH_COMPONENT: foreach $component (File::Spec->path(),
1016                                                 $Config::Config{'binexp'}) {
1017                   next unless defined($component) && $component;
1018                   my($abs) = File::Spec->catfile($component,$perl_name);
1019                   if (MM->maybe_command($abs)) {
1020                       $perl = $abs;
1021                       last DIST_PERLNAME;
1022                   }
1023               }
1024           }
1025     }
1026
1027     return $perl;
1028 }
1029
1030
1031 #-> sub CPAN::exists ;
1032 sub exists {
1033     my($mgr,$class,$id) = @_;
1034     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
1035     CPAN::Index->reload;
1036     ### Carp::croak "exists called without class argument" unless $class;
1037     $id ||= "";
1038     $id =~ s/:+/::/g if $class eq "CPAN::Module";
1039     my $exists;
1040     if (CPAN::_sqlite_running) {
1041         $exists = (exists $META->{readonly}{$class}{$id} or
1042                    $CPAN::SQLite->set($class, $id));
1043     } else {
1044         $exists =  exists $META->{readonly}{$class}{$id};
1045     }
1046     $exists ||= exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
1047 }
1048
1049 #-> sub CPAN::delete ;
1050 sub delete {
1051   my($mgr,$class,$id) = @_;
1052   delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
1053   delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
1054 }
1055
1056 #-> sub CPAN::has_usable
1057 # has_inst is sometimes too optimistic, we should replace it with this
1058 # has_usable whenever a case is given
1059 sub has_usable {
1060     my($self,$mod,$message) = @_;
1061     return 1 if $HAS_USABLE->{$mod};
1062     my $has_inst = $self->has_inst($mod,$message);
1063     return unless $has_inst;
1064     my $usable;
1065     $usable = {
1066                LWP => [ # we frequently had "Can't locate object
1067                         # method "new" via package "LWP::UserAgent" at
1068                         # (eval 69) line 2006
1069                        sub {require LWP},
1070                        sub {require LWP::UserAgent},
1071                        sub {require HTTP::Request},
1072                        sub {require URI::URL},
1073                       ],
1074                'Net::FTP' => [
1075                             sub {require Net::FTP},
1076                             sub {require Net::Config},
1077                            ],
1078                'File::HomeDir' => [
1079                                    sub {require File::HomeDir;
1080                                         unless (File::HomeDir::->VERSION >= 0.52){
1081                                             for ("Will not use File::HomeDir, need 0.52\n") {
1082                                                 $CPAN::Frontend->mywarn($_);
1083                                                 die $_;
1084                                             }
1085                                         }
1086                                     },
1087                                   ],
1088                'Archive::Tar' => [
1089                                   sub {require Archive::Tar;
1090                                        unless (Archive::Tar::->VERSION >= 1.00) {
1091                                             for ("Will not use Archive::Tar, need 1.00\n") {
1092                                                 $CPAN::Frontend->mywarn($_);
1093                                                 die $_;
1094                                             }
1095                                        }
1096                                   },
1097                                  ],
1098               };
1099     if ($usable->{$mod}) {
1100         for my $c (0..$#{$usable->{$mod}}) {
1101             my $code = $usable->{$mod}[$c];
1102             my $ret = eval { &$code() };
1103             $ret = "" unless defined $ret;
1104             if ($@) {
1105                 # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
1106                 return;
1107             }
1108         }
1109     }
1110     return $HAS_USABLE->{$mod} = 1;
1111 }
1112
1113 #-> sub CPAN::has_inst
1114 sub has_inst {
1115     my($self,$mod,$message) = @_;
1116     Carp::croak("CPAN->has_inst() called without an argument")
1117         unless defined $mod;
1118     my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
1119         keys %{$CPAN::Config->{dontload_hash}||{}},
1120             @{$CPAN::Config->{dontload_list}||[]};
1121     if (defined $message && $message eq "no"  # afair only used by Nox
1122         ||
1123         $dont{$mod}
1124        ) {
1125       $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
1126       return 0;
1127     }
1128     my $file = $mod;
1129     my $obj;
1130     $file =~ s|::|/|g;
1131     $file .= ".pm";
1132     if ($INC{$file}) {
1133         # checking %INC is wrong, because $INC{LWP} may be true
1134         # although $INC{"URI/URL.pm"} may have failed. But as
1135         # I really want to say "bla loaded OK", I have to somehow
1136         # cache results.
1137         ### warn "$file in %INC"; #debug
1138         return 1;
1139     } elsif (eval { require $file }) {
1140         # eval is good: if we haven't yet read the database it's
1141         # perfect and if we have installed the module in the meantime,
1142         # it tries again. The second require is only a NOOP returning
1143         # 1 if we had success, otherwise it's retrying
1144
1145         my $v = eval "\$$mod\::VERSION";
1146         $v = $v ? " (v$v)" : "";
1147         $CPAN::Frontend->myprint("CPAN: $mod loaded ok$v\n");
1148         if ($mod eq "CPAN::WAIT") {
1149             push @CPAN::Shell::ISA, 'CPAN::WAIT';
1150         }
1151         return 1;
1152     } elsif ($mod eq "Net::FTP") {
1153         $CPAN::Frontend->mywarn(qq{
1154   Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
1155   if you just type
1156       install Bundle::libnet
1157
1158 }) unless $Have_warned->{"Net::FTP"}++;
1159         $CPAN::Frontend->mysleep(3);
1160     } elsif ($mod eq "Digest::SHA"){
1161         if ($Have_warned->{"Digest::SHA"}++) {
1162             $CPAN::Frontend->myprint(qq{CPAN: checksum security checks disabled }.
1163                                      qq{because Digest::SHA not installed.\n});
1164         } else {
1165             $CPAN::Frontend->mywarn(qq{
1166   CPAN: checksum security checks disabled because Digest::SHA not installed.
1167   Please consider installing the Digest::SHA module.
1168
1169 });
1170             $CPAN::Frontend->mysleep(2);
1171         }
1172     } elsif ($mod eq "Module::Signature"){
1173         # NOT prefs_lookup, we are not a distro
1174         my $check_sigs = $CPAN::Config->{check_sigs};
1175         if (not $check_sigs) {
1176             # they do not want us:-(
1177         } elsif (not $Have_warned->{"Module::Signature"}++) {
1178             # No point in complaining unless the user can
1179             # reasonably install and use it.
1180             if (eval { require Crypt::OpenPGP; 1 } ||
1181                 (
1182                  defined $CPAN::Config->{'gpg'}
1183                  &&
1184                  $CPAN::Config->{'gpg'} =~ /\S/
1185                 )
1186                ) {
1187                 $CPAN::Frontend->mywarn(qq{
1188   CPAN: Module::Signature security checks disabled because Module::Signature
1189   not installed.  Please consider installing the Module::Signature module.
1190   You may also need to be able to connect over the Internet to the public
1191   keyservers like pgp.mit.edu (port 11371).
1192
1193 });
1194                 $CPAN::Frontend->mysleep(2);
1195             }
1196         }
1197     } else {
1198         delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
1199     }
1200     return 0;
1201 }
1202
1203 #-> sub CPAN::instance ;
1204 sub instance {
1205     my($mgr,$class,$id) = @_;
1206     CPAN::Index->reload;
1207     $id ||= "";
1208     # unsafe meta access, ok?
1209     return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
1210     $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
1211 }
1212
1213 #-> sub CPAN::new ;
1214 sub new {
1215     bless {}, shift;
1216 }
1217
1218 #-> sub CPAN::cleanup ;
1219 sub cleanup {
1220   # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
1221   local $SIG{__DIE__} = '';
1222   my($message) = @_;
1223   my $i = 0;
1224   my $ineval = 0;
1225   my($subroutine);
1226   while ((undef,undef,undef,$subroutine) = caller(++$i)) {
1227       $ineval = 1, last if
1228           $subroutine eq '(eval)';
1229   }
1230   return if $ineval && !$CPAN::End;
1231   return unless defined $META->{LOCK};
1232   return unless -f $META->{LOCK};
1233   $META->savehist;
1234   close $META->{LOCKFH};
1235   unlink $META->{LOCK};
1236   # require Carp;
1237   # Carp::cluck("DEBUGGING");
1238   if ( $CPAN::CONFIG_DIRTY ) {
1239       $CPAN::Frontend->mywarn("Warning: Configuration not saved.\n");
1240   }
1241   $CPAN::Frontend->myprint("Lockfile removed.\n");
1242 }
1243
1244 #-> sub CPAN::readhist
1245 sub readhist {
1246     my($self,$term,$histfile) = @_;
1247     my($fh) = FileHandle->new;
1248     open $fh, "<$histfile" or last;
1249     local $/ = "\n";
1250     while (<$fh>) {
1251         chomp;
1252         $term->AddHistory($_);
1253     }
1254     close $fh;
1255 }
1256
1257 #-> sub CPAN::savehist
1258 sub savehist {
1259     my($self) = @_;
1260     my($histfile,$histsize);
1261     unless ($histfile = $CPAN::Config->{'histfile'}){
1262         $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
1263         return;
1264     }
1265     $histsize = $CPAN::Config->{'histsize'} || 100;
1266     if ($CPAN::term){
1267         unless ($CPAN::term->can("GetHistory")) {
1268             $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
1269             return;
1270         }
1271     } else {
1272         return;
1273     }
1274     my @h = $CPAN::term->GetHistory;
1275     splice @h, 0, @h-$histsize if @h>$histsize;
1276     my($fh) = FileHandle->new;
1277     open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
1278     local $\ = local $, = "\n";
1279     print $fh @h;
1280     close $fh;
1281 }
1282
1283 #-> sub CPAN::is_tested
1284 sub is_tested {
1285     my($self,$what,$when) = @_;
1286     unless ($what) {
1287         Carp::cluck("DEBUG: empty what");
1288         return;
1289     }
1290     $self->{is_tested}{$what} = $when;
1291 }
1292
1293 #-> sub CPAN::is_installed
1294 # unsets the is_tested flag: as soon as the thing is installed, it is
1295 # not needed in set_perl5lib anymore
1296 sub is_installed {
1297     my($self,$what) = @_;
1298     delete $self->{is_tested}{$what};
1299 }
1300
1301 sub _list_sorted_descending_is_tested {
1302     my($self) = @_;
1303     sort
1304         { ($self->{is_tested}{$b}||0) <=> ($self->{is_tested}{$a}||0) }
1305             keys %{$self->{is_tested}}
1306 }
1307
1308 #-> sub CPAN::set_perl5lib
1309 sub set_perl5lib {
1310     my($self,$for) = @_;
1311     unless ($for) {
1312         (undef,undef,undef,$for) = caller(1);
1313         $for =~ s/.*://;
1314     }
1315     $self->{is_tested} ||= {};
1316     return unless %{$self->{is_tested}};
1317     my $env = $ENV{PERL5LIB};
1318     $env = $ENV{PERLLIB} unless defined $env;
1319     my @env;
1320     push @env, $env if defined $env and length $env;
1321     #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
1322     #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
1323
1324     my @dirs = map {("$_/blib/arch", "$_/blib/lib")} $self->_list_sorted_descending_is_tested;
1325     if (@dirs < 12) {
1326         $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB for '$for'\n");
1327     } elsif (@dirs < 24) {
1328         my @d = map {my $cp = $_;
1329                      $cp =~ s/^\Q$CPAN::Config->{build_dir}\E/%BUILDDIR%/;
1330                      $cp
1331                  } @dirs;
1332         $CPAN::Frontend->myprint("Prepending @d to PERL5LIB; ".
1333                                  "%BUILDDIR%=$CPAN::Config->{build_dir} ".
1334                                  "for '$for'\n"
1335                                 );
1336     } else {
1337         my $cnt = keys %{$self->{is_tested}};
1338         $CPAN::Frontend->myprint("Prepending blib/arch and blib/lib of ".
1339                                  "$cnt build dirs to PERL5LIB; ".
1340                                  "for '$for'\n"
1341                                 );
1342     }
1343
1344     $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1345 }
1346
1347 package CPAN::CacheMgr;
1348 use strict;
1349
1350 #-> sub CPAN::CacheMgr::as_string ;
1351 sub as_string {
1352     eval { require Data::Dumper };
1353     if ($@) {
1354         return shift->SUPER::as_string;
1355     } else {
1356         return Data::Dumper::Dumper(shift);
1357     }
1358 }
1359
1360 #-> sub CPAN::CacheMgr::cachesize ;
1361 sub cachesize {
1362     shift->{DU};
1363 }
1364
1365 #-> sub CPAN::CacheMgr::tidyup ;
1366 sub tidyup {
1367   my($self) = @_;
1368   return unless $CPAN::META->{LOCK};
1369   return unless -d $self->{ID};
1370   while ($self->{DU} > $self->{'MAX'} ) {
1371     my($toremove) = shift @{$self->{FIFO}};
1372     unless ($toremove =~ /\.yml$/) {
1373         $CPAN::Frontend->myprint(sprintf(
1374                                          "DEL(%.1f>%.1fMB): %s \n",
1375                                          $self->{DU},
1376                                          $self->{MAX},
1377                                          $toremove,
1378                                         )
1379                                 );
1380     }
1381     return if $CPAN::Signal;
1382     $self->_clean_cache($toremove);
1383     return if $CPAN::Signal;
1384   }
1385 }
1386
1387 #-> sub CPAN::CacheMgr::dir ;
1388 sub dir {
1389     shift->{ID};
1390 }
1391
1392 #-> sub CPAN::CacheMgr::entries ;
1393 sub entries {
1394     my($self,$dir) = @_;
1395     return unless defined $dir;
1396     $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
1397     $dir ||= $self->{ID};
1398     my($cwd) = CPAN::anycwd();
1399     chdir $dir or Carp::croak("Can't chdir to $dir: $!");
1400     my $dh = DirHandle->new(File::Spec->curdir)
1401         or Carp::croak("Couldn't opendir $dir: $!");
1402     my(@entries);
1403     for ($dh->read) {
1404         next if $_ eq "." || $_ eq "..";
1405         if (-f $_) {
1406             push @entries, File::Spec->catfile($dir,$_);
1407         } elsif (-d _) {
1408             push @entries, File::Spec->catdir($dir,$_);
1409         } else {
1410             $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
1411         }
1412     }
1413     chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
1414     sort { -M $b <=> -M $a} @entries;
1415 }
1416
1417 #-> sub CPAN::CacheMgr::disk_usage ;
1418 sub disk_usage {
1419     my($self,$dir) = @_;
1420     return if exists $self->{SIZE}{$dir};
1421     return if $CPAN::Signal;
1422     my($Du) = 0;
1423     if (-e $dir) {
1424         unless (-x $dir) {
1425             unless (chmod 0755, $dir) {
1426                 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
1427                                         "permission to change the permission; cannot ".
1428                                         "estimate disk usage of '$dir'\n");
1429                 $CPAN::Frontend->mysleep(5);
1430                 return;
1431             }
1432         }
1433     } else {
1434         $CPAN::Frontend->mywarn("Directory '$dir' has gone. Cannot continue.\n");
1435         return;
1436     }
1437     find(
1438          sub {
1439            $File::Find::prune++ if $CPAN::Signal;
1440            return if -l $_;
1441            if ($^O eq 'MacOS') {
1442              require Mac::Files;
1443              my $cat  = Mac::Files::FSpGetCatInfo($_);
1444              $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
1445            } else {
1446              if (-d _) {
1447                unless (-x _) {
1448                  unless (chmod 0755, $_) {
1449                    $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
1450                                            "the permission to change the permission; ".
1451                                            "can only partially estimate disk usage ".
1452                                            "of '$_'\n");
1453                    $CPAN::Frontend->mysleep(5);
1454                    return;
1455                  }
1456                }
1457              } else {
1458                $Du += (-s _);
1459              }
1460            }
1461          },
1462          $dir
1463         );
1464     return if $CPAN::Signal;
1465     $self->{SIZE}{$dir} = $Du/1024/1024;
1466     push @{$self->{FIFO}}, $dir;
1467     $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
1468     $self->{DU} += $Du/1024/1024;
1469     $self->{DU};
1470 }
1471
1472 #-> sub CPAN::CacheMgr::_clean_cache ;
1473 sub _clean_cache {
1474     my($self,$dir) = @_;
1475     return unless -e $dir;
1476     unless (File::Spec->canonpath(File::Basename::dirname($dir))
1477             eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
1478         $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
1479                                 "will not remove\n");
1480         $CPAN::Frontend->mysleep(5);
1481         return;
1482     }
1483     $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
1484         if $CPAN::DEBUG;
1485     File::Path::rmtree($dir);
1486     my $id_deleted = 0;
1487     if ($dir !~ /\.yml$/ && -f "$dir.yml") {
1488         my $yaml_module = CPAN::_yaml_module;
1489         if ($CPAN::META->has_inst($yaml_module)) {
1490             my($peek_yaml) = CPAN->_yaml_loadfile("$dir.yml");
1491             if (my $id = $peek_yaml->[0]{distribution}{ID}) {
1492                 $CPAN::META->delete("CPAN::Distribution", $id);
1493                 # $CPAN::Frontend->mywarn (" +++\n");
1494                 $id_deleted++;
1495             }
1496         }
1497         unlink "$dir.yml"; # may fail
1498         unless ($id_deleted) {
1499             CPAN->debug("no distro found associated with '$dir'");
1500         }
1501     }
1502     $self->{DU} -= $self->{SIZE}{$dir};
1503     delete $self->{SIZE}{$dir};
1504 }
1505
1506 #-> sub CPAN::CacheMgr::new ;
1507 sub new {
1508     my $class = shift;
1509     my $time = time;
1510     my($debug,$t2);
1511     $debug = "";
1512     my $self = {
1513                 ID => $CPAN::Config->{build_dir},
1514                 MAX => $CPAN::Config->{'build_cache'},
1515                 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
1516                 DU => 0
1517                };
1518     File::Path::mkpath($self->{ID});
1519     my $dh = DirHandle->new($self->{ID});
1520     bless $self, $class;
1521     $self->scan_cache;
1522     $t2 = time;
1523     $debug .= "timing of CacheMgr->new: ".($t2 - $time);
1524     $time = $t2;
1525     CPAN->debug($debug) if $CPAN::DEBUG;
1526     $self;
1527 }
1528
1529 #-> sub CPAN::CacheMgr::scan_cache ;
1530 sub scan_cache {
1531     my $self = shift;
1532     return if $self->{SCAN} eq 'never';
1533     $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
1534         unless $self->{SCAN} eq 'atstart';
1535     return unless $CPAN::META->{LOCK};
1536     $CPAN::Frontend->myprint(
1537                              sprintf("Scanning cache %s for sizes\n",
1538                                      $self->{ID}));
1539     my $e;
1540     my @entries = grep { !/^\.\.?$/ } $self->entries($self->{ID});
1541     my $i = 0;
1542     my $painted = 0;
1543     for $e (@entries) {
1544         # next if $e eq ".." || $e eq ".";
1545         $self->disk_usage($e);
1546         $i++;
1547         while (($painted/76) < ($i/@entries)) {
1548             $CPAN::Frontend->myprint(".");
1549             $painted++;
1550         }
1551         return if $CPAN::Signal;
1552     }
1553     $CPAN::Frontend->myprint("DONE\n");
1554     $self->tidyup;
1555 }
1556
1557 package CPAN::Shell;
1558 use strict;
1559
1560 #-> sub CPAN::Shell::h ;
1561 sub h {
1562     my($class,$about) = @_;
1563     if (defined $about) {
1564         $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1565     } else {
1566         my $filler = " " x (80 - 28 - length($CPAN::VERSION));
1567         $CPAN::Frontend->myprint(qq{
1568 Display Information $filler (ver $CPAN::VERSION)
1569  command  argument          description
1570  a,b,d,m  WORD or /REGEXP/  about authors, bundles, distributions, modules
1571  i        WORD or /REGEXP/  about any of the above
1572  ls       AUTHOR or GLOB    about files in the author's directory
1573     (with WORD being a module, bundle or author name or a distribution
1574     name of the form AUTHOR/DISTRIBUTION)
1575
1576 Download, Test, Make, Install...
1577  get      download                     clean    make clean
1578  make     make (implies get)           look     open subshell in dist directory
1579  test     make test (implies make)     readme   display these README files
1580  install  make install (implies test)  perldoc  display POD documentation
1581
1582 Upgrade
1583  r        WORDs or /REGEXP/ or NONE    report updates for some/matching/all modules
1584  upgrade  WORDs or /REGEXP/ or NONE    upgrade some/matching/all modules
1585
1586 Pragmas
1587  force  CMD    try hard to do command  fforce CMD    try harder
1588  notest CMD    skip testing
1589
1590 Other
1591  h,?           display this menu       ! perl-code   eval a perl command
1592  o conf [opt]  set and query options   q             quit the cpan shell
1593  reload cpan   load CPAN.pm again      reload index  load newer indices
1594  autobundle    Snapshot                recent        latest CPAN uploads});
1595 }
1596 }
1597
1598 *help = \&h;
1599
1600 #-> sub CPAN::Shell::a ;
1601 sub a {
1602   my($self,@arg) = @_;
1603   # authors are always UPPERCASE
1604   for (@arg) {
1605     $_ = uc $_ unless /=/;
1606   }
1607   $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1608 }
1609
1610 #-> sub CPAN::Shell::globls ;
1611 sub globls {
1612     my($self,$s,$pragmas) = @_;
1613     # ls is really very different, but we had it once as an ordinary
1614     # command in the Shell (upto rev. 321) and we could not handle
1615     # force well then
1616     my(@accept,@preexpand);
1617     if ($s =~ /[\*\?\/]/) {
1618         if ($CPAN::META->has_inst("Text::Glob")) {
1619             if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
1620                 my $rau = Text::Glob::glob_to_regex(uc $au);
1621                 CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
1622                       if $CPAN::DEBUG;
1623                 push @preexpand, map { $_->id . "/" . $pathglob }
1624                     CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
1625             } else {
1626                 my $rau = Text::Glob::glob_to_regex(uc $s);
1627                 push @preexpand, map { $_->id }
1628                     CPAN::Shell->expand_by_method('CPAN::Author',
1629                                                   ['id'],
1630                                                   "/$rau/");
1631             }
1632         } else {
1633             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
1634         }
1635     } else {
1636         push @preexpand, uc $s;
1637     }
1638     for (@preexpand) {
1639         unless (/^[A-Z0-9\-]+(\/|$)/i) {
1640             $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
1641             next;
1642         }
1643         push @accept, $_;
1644     }
1645     my $silent = @accept>1;
1646     my $last_alpha = "";
1647     my @results;
1648     for my $a (@accept){
1649         my($author,$pathglob);
1650         if ($a =~ m|(.*?)/(.*)|) {
1651             my $a2 = $1;
1652             $pathglob = $2;
1653             $author = CPAN::Shell->expand_by_method('CPAN::Author',
1654                                                     ['id'],
1655                                                     $a2)
1656                 or $CPAN::Frontend->mydie("No author found for $a2\n");
1657         } else {
1658             $author = CPAN::Shell->expand_by_method('CPAN::Author',
1659                                                     ['id'],
1660                                                     $a)
1661                 or $CPAN::Frontend->mydie("No author found for $a\n");
1662         }
1663         if ($silent) {
1664             my $alpha = substr $author->id, 0, 1;
1665             my $ad;
1666             if ($alpha eq $last_alpha) {
1667                 $ad = "";
1668             } else {
1669                 $ad = "[$alpha]";
1670                 $last_alpha = $alpha;
1671             }
1672             $CPAN::Frontend->myprint($ad);
1673         }
1674         for my $pragma (@$pragmas) {
1675             if ($author->can($pragma)) {
1676                 $author->$pragma();
1677             }
1678         }
1679         push @results, $author->ls($pathglob,$silent); # silent if
1680                                                        # more than one
1681                                                        # author
1682         for my $pragma (@$pragmas) {
1683             my $unpragma = "un$pragma";
1684             if ($author->can($unpragma)) {
1685                 $author->$unpragma();
1686             }
1687         }
1688     }
1689     @results;
1690 }
1691
1692 #-> sub CPAN::Shell::local_bundles ;
1693 sub local_bundles {
1694     my($self,@which) = @_;
1695     my($incdir,$bdir,$dh);
1696     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1697         my @bbase = "Bundle";
1698         while (my $bbase = shift @bbase) {
1699             $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
1700             CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1701             if ($dh = DirHandle->new($bdir)) { # may fail
1702                 my($entry);
1703                 for $entry ($dh->read) {
1704                     next if $entry =~ /^\./;
1705                     next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/;
1706                     if (-d File::Spec->catdir($bdir,$entry)){
1707                         push @bbase, "$bbase\::$entry";
1708                     } else {
1709                         next unless $entry =~ s/\.pm(?!\n)\Z//;
1710                         $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1711                     }
1712                 }
1713             }
1714         }
1715     }
1716 }
1717
1718 #-> sub CPAN::Shell::b ;
1719 sub b {
1720     my($self,@which) = @_;
1721     CPAN->debug("which[@which]") if $CPAN::DEBUG;
1722     $self->local_bundles;
1723     $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1724 }
1725
1726 #-> sub CPAN::Shell::d ;
1727 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1728
1729 #-> sub CPAN::Shell::m ;
1730 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1731     my $self = shift;
1732     $CPAN::Frontend->myprint($self->format_result('Module',@_));
1733 }
1734
1735 #-> sub CPAN::Shell::i ;
1736 sub i {
1737     my($self) = shift;
1738     my(@args) = @_;
1739     @args = '/./' unless @args;
1740     my(@result);
1741     for my $type (qw/Bundle Distribution Module/) {
1742         push @result, $self->expand($type,@args);
1743     }
1744     # Authors are always uppercase.
1745     push @result, $self->expand("Author", map { uc $_ } @args);
1746
1747     my $result = @result == 1 ?
1748         $result[0]->as_string :
1749             @result == 0 ?
1750                 "No objects found of any type for argument @args\n" :
1751                     join("",
1752                          (map {$_->as_glimpse} @result),
1753                          scalar @result, " items found\n",
1754                         );
1755     $CPAN::Frontend->myprint($result);
1756 }
1757
1758 #-> sub CPAN::Shell::o ;
1759
1760 # CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o
1761 # conf' calls through to CPAN::HandleConfig::edit. 'o conf' should
1762 # probably have been called 'set' and 'o debug' maybe 'set debug' or
1763 # 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm
1764 sub o {
1765     my($self,$o_type,@o_what) = @_;
1766     $o_type ||= "";
1767     CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1768     if ($o_type eq 'conf') {
1769         if (!@o_what) { # print all things, "o conf"
1770             my($k,$v);
1771             $CPAN::Frontend->myprint("\$CPAN::Config options from ");
1772             my @from;
1773             if (exists $INC{'CPAN/Config.pm'}) {
1774                 push @from, $INC{'CPAN/Config.pm'};
1775             }
1776             if (exists $INC{'CPAN/MyConfig.pm'}) {
1777                 push @from, $INC{'CPAN/MyConfig.pm'};
1778             }
1779             $CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from);
1780             $CPAN::Frontend->myprint(":\n");
1781             for $k (sort keys %CPAN::HandleConfig::can) {
1782                 $v = $CPAN::HandleConfig::can{$k};
1783                 $CPAN::Frontend->myprint(sprintf "    %-18s [%s]\n", $k, $v);
1784             }
1785             $CPAN::Frontend->myprint("\n");
1786             for $k (sort keys %$CPAN::Config) {
1787                 CPAN::HandleConfig->prettyprint($k);
1788             }
1789             $CPAN::Frontend->myprint("\n");
1790         } else {
1791             if (CPAN::HandleConfig->edit(@o_what)) {
1792             } else {
1793                 $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
1794                                          qq{items\n\n});
1795             }
1796         }
1797     } elsif ($o_type eq 'debug') {
1798         my(%valid);
1799         @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1800         if (@o_what) {
1801             while (@o_what) {
1802                 my($what) = shift @o_what;
1803                 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
1804                     $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
1805                     next;
1806                 }
1807                 if ( exists $CPAN::DEBUG{$what} ) {
1808                     $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1809                 } elsif ($what =~ /^\d/) {
1810                     $CPAN::DEBUG = $what;
1811                 } elsif (lc $what eq 'all') {
1812                     my($max) = 0;
1813                     for (values %CPAN::DEBUG) {
1814                         $max += $_;
1815                     }
1816                     $CPAN::DEBUG = $max;
1817                 } else {
1818                     my($known) = 0;
1819                     for (keys %CPAN::DEBUG) {
1820                         next unless lc($_) eq lc($what);
1821                         $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1822                         $known = 1;
1823                     }
1824                     $CPAN::Frontend->myprint("unknown argument [$what]\n")
1825                         unless $known;
1826                 }
1827             }
1828         } else {
1829           my $raw = "Valid options for debug are ".
1830               join(", ",sort(keys %CPAN::DEBUG), 'all').
1831                   qq{ or a number. Completion works on the options. }.
1832                       qq{Case is ignored.};
1833           require Text::Wrap;
1834           $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1835           $CPAN::Frontend->myprint("\n\n");
1836         }
1837         if ($CPAN::DEBUG) {
1838             $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n");
1839             my($k,$v);
1840             for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1841                 $v = $CPAN::DEBUG{$k};
1842                 $CPAN::Frontend->myprint(sprintf "    %-14s(%s)\n", $k, $v)
1843                     if $v & $CPAN::DEBUG;
1844             }
1845         } else {
1846             $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1847         }
1848     } else {
1849         $CPAN::Frontend->myprint(qq{
1850 Known options:
1851   conf    set or get configuration variables
1852   debug   set or get debugging options
1853 });
1854     }
1855 }
1856
1857 # CPAN::Shell::paintdots_onreload
1858 sub paintdots_onreload {
1859     my($ref) = shift;
1860     sub {
1861         if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
1862             my($subr) = $1;
1863             ++$$ref;
1864             local($|) = 1;
1865             # $CPAN::Frontend->myprint(".($subr)");
1866             $CPAN::Frontend->myprint(".");
1867             if ($subr =~ /\bshell\b/i) {
1868                 # warn "debug[$_[0]]";
1869
1870                 # It would be nice if we could detect that a
1871                 # subroutine has actually changed, but for now we
1872                 # practically always set the GOTOSHELL global
1873
1874                 $CPAN::GOTOSHELL=1;
1875             }
1876             return;
1877         }
1878         warn @_;
1879     };
1880 }
1881
1882 #-> sub CPAN::Shell::hosts ;
1883 sub hosts {
1884     my($self) = @_;
1885     my $fullstats = CPAN::FTP->_ftp_statistics();
1886     my $history = $fullstats->{history} || [];
1887     my %S; # statistics
1888     while (my $last = pop @$history) {
1889         my $attempts = $last->{attempts} or next;
1890         my $start;
1891         if (@$attempts) {
1892             $start = $attempts->[-1]{start};
1893             if ($#$attempts > 0) {
1894                 for my $i (0..$#$attempts-1) {
1895                     my $url = $attempts->[$i]{url} or next;
1896                     $S{no}{$url}++;
1897                 }
1898             }
1899         } else {
1900             $start = $last->{start};
1901         }
1902         next unless $last->{thesiteurl}; # C-C? bad filenames?
1903         $S{start} = $start;
1904         $S{end} ||= $last->{end};
1905         my $dltime = $last->{end} - $start;
1906         my $dlsize = $last->{filesize} || 0;
1907         my $url = ref $last->{thesiteurl} ? $last->{thesiteurl}->text : $last->{thesiteurl};
1908         my $s = $S{ok}{$url} ||= {};
1909         $s->{n}++;
1910         $s->{dlsize} ||= 0;
1911         $s->{dlsize} += $dlsize/1024;
1912         $s->{dltime} ||= 0;
1913         $s->{dltime} += $dltime;
1914     }
1915     my $res;
1916     for my $url (keys %{$S{ok}}) {
1917         next if $S{ok}{$url}{dltime} == 0; # div by zero
1918         push @{$res->{ok}}, [@{$S{ok}{$url}}{qw(n dlsize dltime)},
1919                              $S{ok}{$url}{dlsize}/$S{ok}{$url}{dltime},
1920                              $url,
1921                             ];
1922     }
1923     for my $url (keys %{$S{no}}) {
1924         push @{$res->{no}}, [$S{no}{$url},
1925                              $url,
1926                             ];
1927     }
1928     my $R = ""; # report
1929     if ($S{start} && $S{end}) {
1930         $R .= sprintf "Log starts: %s\n", $S{start} ? scalar(localtime $S{start}) : "unknown";
1931         $R .= sprintf "Log ends  : %s\n", $S{end}   ? scalar(localtime $S{end})   : "unknown";
1932     }
1933     if ($res->{ok} && @{$res->{ok}}) {
1934         $R .= sprintf "\nSuccessful downloads:
1935    N       kB  secs      kB/s url\n";
1936         my $i = 20;
1937         for (sort { $b->[3] <=> $a->[3] } @{$res->{ok}}) {
1938             $R .= sprintf "%4d %8d %5d %9.1f %s\n", @$_;
1939             last if --$i<=0;
1940         }
1941     }
1942     if ($res->{no} && @{$res->{no}}) {
1943         $R .= sprintf "\nUnsuccessful downloads:\n";
1944         my $i = 20;
1945         for (sort { $b->[0] <=> $a->[0] } @{$res->{no}}) {
1946             $R .= sprintf "%4d %s\n", @$_;
1947             last if --$i<=0;
1948         }
1949     }
1950     $CPAN::Frontend->myprint($R);
1951 }
1952
1953 #-> sub CPAN::Shell::reload ;
1954 sub reload {
1955     my($self,$command,@arg) = @_;
1956     $command ||= "";
1957     $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1958     if ($command =~ /^cpan$/i) {
1959         my $redef = 0;
1960         chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
1961         my $failed;
1962         my @relo = (
1963                     "CPAN.pm",
1964                     "CPAN/Debug.pm",
1965                     "CPAN/FirstTime.pm",
1966                     "CPAN/HandleConfig.pm",
1967                     "CPAN/Kwalify.pm",
1968                     "CPAN/Queue.pm",
1969                     "CPAN/Reporter.pm",
1970                     "CPAN/SQLite.pm",
1971                     "CPAN/Tarzip.pm",
1972                     "CPAN/Version.pm",
1973                    );
1974       MFILE: for my $f (@relo) {
1975             next unless exists $INC{$f};
1976             my $p = $f;
1977             $p =~ s/\.pm$//;
1978             $p =~ s|/|::|g;
1979             $CPAN::Frontend->myprint("($p");
1980             local($SIG{__WARN__}) = paintdots_onreload(\$redef);
1981             $self->_reload_this($f) or $failed++;
1982             my $v = eval "$p\::->VERSION";
1983             $CPAN::Frontend->myprint("v$v)");
1984         }
1985         $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1986         if ($failed) {
1987             my $errors = $failed == 1 ? "error" : "errors";
1988             $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ".
1989                                     "this session.\n");
1990         }
1991     } elsif ($command =~ /^index$/i) {
1992       CPAN::Index->force_reload;
1993     } else {
1994       $CPAN::Frontend->myprint(qq{cpan     re-evals the CPAN modules
1995 index    re-reads the index files\n});
1996     }
1997 }
1998
1999 # reload means only load again what we have loaded before
2000 #-> sub CPAN::Shell::_reload_this ;
2001 sub _reload_this {
2002     my($self,$f,$args) = @_;
2003     CPAN->debug("f[$f]") if $CPAN::DEBUG;
2004     return 1 unless $INC{$f}; # we never loaded this, so we do not
2005                               # reload but say OK
2006     my $pwd = CPAN::anycwd();
2007     CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG;
2008     my($file);
2009     for my $inc (@INC) {
2010         $file = File::Spec->catfile($inc,split /\//, $f);
2011         last if -f $file;
2012         $file = "";
2013     }
2014     CPAN->debug("file[$file]") if $CPAN::DEBUG;
2015     my @inc = @INC;
2016     unless ($file && -f $file) {
2017         # this thingie is not in the INC path, maybe CPAN/MyConfig.pm?
2018         $file = $INC{$f};
2019         unless (CPAN->has_inst("File::Basename")) {
2020             @inc = File::Basename::dirname($file);
2021         } else {
2022             # do we ever need this?
2023             @inc = substr($file,0,-length($f)-1); # bring in back to me!
2024         }
2025     }
2026     CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG;
2027     unless (-f $file) {
2028         $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
2029         return;
2030     }
2031     my $mtime = (stat $file)[9];
2032     $reload->{$f} ||= $^T;
2033     my $must_reload = $mtime > $reload->{$f};
2034     $args ||= {};
2035     $must_reload ||= $args->{reloforce};
2036     if ($must_reload) {
2037         my $fh = FileHandle->new($file) or
2038             $CPAN::Frontend->mydie("Could not open $file: $!");
2039         local($/);
2040         local $^W = 1;
2041         my $content = <$fh>;
2042         CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
2043             if $CPAN::DEBUG;
2044         delete $INC{$f};
2045         local @INC = @inc;
2046         eval "require '$f'";
2047         if ($@){
2048             warn $@;
2049             return;
2050         }
2051         $reload->{$f} = time;
2052     } else {
2053         $CPAN::Frontend->myprint("__unchanged__");
2054     }
2055     return 1;
2056 }
2057
2058 #-> sub CPAN::Shell::mkmyconfig ;
2059 sub mkmyconfig {
2060     my($self, $cpanpm, %args) = @_;
2061     require CPAN::FirstTime;
2062     my $home = CPAN::HandleConfig::home;
2063     $cpanpm = $INC{'CPAN/MyConfig.pm'} ||
2064         File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm");
2065     File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm;
2066     CPAN::HandleConfig::require_myconfig_or_config;
2067     $CPAN::Config ||= {};
2068     $CPAN::Config = {
2069         %$CPAN::Config,
2070         build_dir           =>  undef,
2071         cpan_home           =>  undef,
2072         keep_source_where   =>  undef,
2073         histfile            =>  undef,
2074     };
2075     CPAN::FirstTime::init($cpanpm, %args);
2076 }
2077
2078 #-> sub CPAN::Shell::_binary_extensions ;
2079 sub _binary_extensions {
2080     my($self) = shift @_;
2081     my(@result,$module,%seen,%need,$headerdone);
2082     for $module ($self->expand('Module','/./')) {
2083         my $file  = $module->cpan_file;
2084         next if $file eq "N/A";
2085         next if $file =~ /^Contact Author/;
2086         my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
2087         next if $dist->isa_perl;
2088         next unless $module->xs_file;
2089         local($|) = 1;
2090         $CPAN::Frontend->myprint(".");
2091         push @result, $module;
2092     }
2093 #    print join " | ", @result;
2094     $CPAN::Frontend->myprint("\n");
2095     return @result;
2096 }
2097
2098 #-> sub CPAN::Shell::recompile ;
2099 sub recompile {
2100     my($self) = shift @_;
2101     my($module,@module,$cpan_file,%dist);
2102     @module = $self->_binary_extensions();
2103     for $module (@module){  # we force now and compile later, so we
2104                             # don't do it twice
2105         $cpan_file = $module->cpan_file;
2106         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
2107         $pack->force; #
2108         $dist{$cpan_file}++;
2109     }
2110     for $cpan_file (sort keys %dist) {
2111         $CPAN::Frontend->myprint("  CPAN: Recompiling $cpan_file\n\n");
2112         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
2113         $pack->install;
2114         $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
2115                            # stop a package from recompiling,
2116                            # e.g. IO-1.12 when we have perl5.003_10
2117     }
2118 }
2119
2120 #-> sub CPAN::Shell::scripts ;
2121 sub scripts {
2122     my($self, $arg) = @_;
2123     $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");
2124
2125     for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) {
2126         unless ($CPAN::META->has_inst($req)) {
2127             $CPAN::Frontend->mywarn("  $req not available\n");
2128         }
2129     }
2130     my $p = HTML::LinkExtor->new();
2131     my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html";
2132     unless (-f $indexfile) {
2133         $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n");
2134     }
2135     $p->parse_file($indexfile);
2136     my @hrefs;
2137     my $qrarg;
2138     if ($arg =~ s|^/(.+)/$|$1|) {
2139         $qrarg = eval 'qr/$arg/'; # hide construct from 5.004
2140     }
2141     for my $l ($p->links) {
2142         my $tag = shift @$l;
2143         next unless $tag eq "a";
2144         my %att = @$l;
2145         my $href = $att{href};
2146         next unless $href =~ s|^\.\./authors/id/./../||;
2147         if ($arg) {
2148             if ($qrarg) {
2149                 if ($href =~ $qrarg) {
2150                     push @hrefs, $href;
2151                 }
2152             } else {
2153                 if ($href =~ /\Q$arg\E/) {
2154                     push @hrefs, $href;
2155                 }
2156             }
2157         } else {
2158             push @hrefs, $href;
2159         }
2160     }
2161     # now filter for the latest version if there is more than one of a name
2162     my %stems;
2163     for (sort @hrefs) {
2164         my $href = $_;
2165         s/-v?\d.*//;
2166         my $stem = $_;
2167         $stems{$stem} ||= [];
2168         push @{$stems{$stem}}, $href;
2169     }
2170     for (sort keys %stems) {
2171         my $highest;
2172         if (@{$stems{$_}} > 1) {
2173             $highest = List::Util::reduce {
2174                 Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b
2175               } @{$stems{$_}};
2176         } else {
2177             $highest = $stems{$_}[0];
2178         }
2179         $CPAN::Frontend->myprint("$highest\n");
2180     }
2181 }
2182
2183 #-> sub CPAN::Shell::report ;
2184 sub report {
2185     my($self,@args) = @_;
2186     unless ($CPAN::META->has_inst("CPAN::Reporter")) {
2187         $CPAN::Frontend->mydie("CPAN::Reporter not installed; cannot continue");
2188     }
2189     local $CPAN::Config->{test_report} = 1;
2190     $self->force("test",@args); # force is there so that the test be
2191                                 # re-run (as documented)
2192 }
2193
2194 # compare with is_tested
2195 #-> sub CPAN::Shell::install_tested
2196 sub install_tested {
2197     my($self,@some) = @_;
2198     $CPAN::Frontend->mywarn("install_tested() must not be called with arguments.\n"),
2199         return if @some;
2200     CPAN::Index->reload;
2201
2202     for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
2203         my $yaml = "$b.yml";
2204         unless (-f $yaml){
2205             $CPAN::Frontend->mywarn("No YAML file for $b available, skipping\n");
2206             next;
2207         }
2208         my $yaml_content = CPAN->_yaml_loadfile($yaml);
2209         my $id = $yaml_content->[0]{distribution}{ID};
2210         unless ($id){
2211             $CPAN::Frontend->mywarn("No ID found in '$yaml', skipping\n");
2212             next;
2213         }
2214         my $do = CPAN::Shell->expandany($id);
2215         unless ($do){
2216             $CPAN::Frontend->mywarn("Could not expand ID '$id', skipping\n");
2217             next;
2218         }
2219         unless ($do->{build_dir}) {
2220             $CPAN::Frontend->mywarn("Distro '$id' has no build_dir, skipping\n");
2221             next;
2222         }
2223         unless ($do->{build_dir} eq $b) {
2224             $CPAN::Frontend->mywarn("Distro '$id' has build_dir '$do->{build_dir}' but expected '$b', skipping\n");
2225             next;
2226         }
2227         push @some, $do;
2228     }
2229
2230     $CPAN::Frontend->mywarn("No tested distributions found.\n"),
2231         return unless @some;
2232
2233     @some = grep { $_->{make_test} && ! $_->{make_test}->failed } @some;
2234     $CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"),
2235         return unless @some;
2236
2237     # @some = grep { not $_->uptodate } @some;
2238     # $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"),
2239     #     return unless @some;
2240
2241     CPAN->debug("some[@some]");
2242     for my $d (@some) {
2243         my $id = $d->can("pretty_id") ? $d->pretty_id : $d->id;
2244         $CPAN::Frontend->myprint("install_tested: Running for $id\n");
2245         $CPAN::Frontend->mysleep(1);
2246         $self->install($d);
2247     }
2248 }
2249
2250 #-> sub CPAN::Shell::upgrade ;
2251 sub upgrade {
2252     my($self,@args) = @_;
2253     $self->install($self->r(@args));
2254 }
2255
2256 #-> sub CPAN::Shell::_u_r_common ;
2257 sub _u_r_common {
2258     my($self) = shift @_;
2259     my($what) = shift @_;
2260     CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
2261     Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
2262           $what && $what =~ /^[aru]$/;
2263     my(@args) = @_;
2264     @args = '/./' unless @args;
2265     my(@result,$module,%seen,%need,$headerdone,
2266        $version_undefs,$version_zeroes);
2267     $version_undefs = $version_zeroes = 0;
2268     my $sprintf = "%s%-25s%s %9s %9s  %s\n";
2269     my @expand = $self->expand('Module',@args);
2270     my $expand = scalar @expand;
2271     if (0) { # Looks like noise to me, was very useful for debugging
2272              # for metadata cache
2273         $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
2274     }
2275   MODULE: for $module (@expand) {
2276         my $file  = $module->cpan_file;
2277         next MODULE unless defined $file; # ??
2278         $file =~ s|^./../||;
2279         my($latest) = $module->cpan_version;
2280         my($inst_file) = $module->inst_file;
2281         my($have);
2282         return if $CPAN::Signal;
2283         if ($inst_file){
2284             if ($what eq "a") {
2285                 $have = $module->inst_version;
2286             } elsif ($what eq "r") {
2287                 $have = $module->inst_version;
2288                 local($^W) = 0;
2289                 if ($have eq "undef"){
2290                     $version_undefs++;
2291                 } elsif ($have == 0){
2292                     $version_zeroes++;
2293                 }
2294                 next MODULE unless CPAN::Version->vgt($latest, $have);
2295 # to be pedantic we should probably say:
2296 #    && !($have eq "undef" && $latest ne "undef" && $latest gt "");
2297 # to catch the case where CPAN has a version 0 and we have a version undef
2298             } elsif ($what eq "u") {
2299                 next MODULE;
2300             }
2301         } else {
2302             if ($what eq "a") {
2303                 next MODULE;
2304             } elsif ($what eq "r") {
2305                 next MODULE;
2306             } elsif ($what eq "u") {
2307                 $have = "-";
2308             }
2309         }
2310         return if $CPAN::Signal; # this is sometimes lengthy
2311         $seen{$file} ||= 0;
2312         if ($what eq "a") {
2313             push @result, sprintf "%s %s\n", $module->id, $have;
2314         } elsif ($what eq "r") {
2315             push @result, $module->id;
2316             next MODULE if $seen{$file}++;
2317         } elsif ($what eq "u") {
2318             push @result, $module->id;
2319             next MODULE if $seen{$file}++;
2320             next MODULE if $file =~ /^Contact/;
2321         }
2322         unless ($headerdone++){
2323             $CPAN::Frontend->myprint("\n");
2324             $CPAN::Frontend->myprint(sprintf(
2325                                              $sprintf,
2326                                              "",
2327                                              "Package namespace",
2328                                              "",
2329                                              "installed",
2330                                              "latest",
2331                                              "in CPAN file"
2332                                             ));
2333         }
2334         my $color_on = "";
2335         my $color_off = "";
2336         if (
2337             $COLOR_REGISTERED
2338             &&
2339             $CPAN::META->has_inst("Term::ANSIColor")
2340             &&
2341             $module->description
2342            ) {
2343             $color_on = Term::ANSIColor::color("green");
2344             $color_off = Term::ANSIColor::color("reset");
2345         }
2346         $CPAN::Frontend->myprint(sprintf $sprintf,
2347                                  $color_on,
2348                                  $module->id,
2349                                  $color_off,
2350                                  $have,
2351                                  $latest,
2352                                  $file);
2353         $need{$module->id}++;
2354     }
2355     unless (%need) {
2356         if ($what eq "u") {
2357             $CPAN::Frontend->myprint("No modules found for @args\n");
2358         } elsif ($what eq "r") {
2359             $CPAN::Frontend->myprint("All modules are up to date for @args\n");
2360         }
2361     }
2362     if ($what eq "r") {
2363         if ($version_zeroes) {
2364             my $s_has = $version_zeroes > 1 ? "s have" : " has";
2365             $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
2366                 qq{a version number of 0\n});
2367         }
2368         if ($version_undefs) {
2369             my $s_has = $version_undefs > 1 ? "s have" : " has";
2370             $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
2371                 qq{parseable version number\n});
2372         }
2373     }
2374     @result;
2375 }
2376
2377 #-> sub CPAN::Shell::r ;
2378 sub r {
2379     shift->_u_r_common("r",@_);
2380 }
2381
2382 #-> sub CPAN::Shell::u ;
2383 sub u {
2384     shift->_u_r_common("u",@_);
2385 }
2386
2387 #-> sub CPAN::Shell::failed ;
2388 sub failed {
2389     my($self,$only_id,$silent) = @_;
2390     my @failed;
2391   DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
2392         my $failed = "";
2393       NAY: for my $nosayer ( # order matters!
2394                             "unwrapped",
2395                             "writemakefile",
2396                             "signature_verify",
2397                             "make",
2398                             "make_test",
2399                             "install",
2400                             "make_clean",
2401                            ) {
2402             next unless exists $d->{$nosayer};
2403             next unless defined $d->{$nosayer};
2404             next unless (
2405                          UNIVERSAL::can($d->{$nosayer},"failed") ?
2406                          $d->{$nosayer}->failed :
2407                          $d->{$nosayer} =~ /^NO/
2408                         );
2409             next NAY if $only_id && $only_id != (
2410                                                  UNIVERSAL::can($d->{$nosayer},"commandid")
2411                                                  ?
2412                                                  $d->{$nosayer}->commandid
2413                                                  :
2414                                                  $CPAN::CurrentCommandId
2415                                                 );
2416             $failed = $nosayer;
2417             last;
2418         }
2419         next DIST unless $failed;
2420         my $id = $d->id;
2421         $id =~ s|^./../||;
2422         #$print .= sprintf(
2423         #                  "  %-45s: %s %s\n",
2424         push @failed,
2425             (
2426              UNIVERSAL::can($d->{$failed},"failed") ?
2427              [
2428               $d->{$failed}->commandid,
2429               $id,
2430               $failed,
2431               $d->{$failed}->text,
2432               $d->{$failed}{TIME}||0,
2433              ] :
2434              [
2435               1,
2436               $id,
2437               $failed,
2438               $d->{$failed},
2439               0,
2440              ]
2441             );
2442     }
2443     my $scope;
2444     if ($only_id) {
2445         $scope = "this command";
2446     } elsif ($CPAN::Index::HAVE_REANIMATED) {
2447         $scope = "this or a previous session";
2448         # it might be nice to have a section for previous session and
2449         # a second for this
2450     } else {
2451         $scope = "this session";
2452     }
2453     if (@failed) {
2454         my $print;
2455         my $debug = 0;
2456         if ($debug) {
2457             $print = join "",
2458                 map { sprintf "%5d %-45s: %s %s\n", @$_ }
2459                     sort { $a->[0] <=> $b->[0] } @failed;
2460         } else {
2461             $print = join "",
2462                 map { sprintf " %-45s: %s %s\n", @$_[1..3] }
2463                     sort {
2464                         $a->[0] <=> $b->[0]
2465                             ||
2466                                 $a->[4] <=> $b->[4]
2467                        } @failed;
2468         }
2469         $CPAN::Frontend->myprint("Failed during $scope:\n$print");
2470     } elsif (!$only_id || !$silent) {
2471         $CPAN::Frontend->myprint("Nothing failed in $scope\n");
2472     }
2473 }
2474
2475 # XXX intentionally undocumented because completely bogus, unportable,
2476 # useless, etc.
2477
2478 #-> sub CPAN::Shell::status ;
2479 sub status {
2480     my($self) = @_;
2481     require Devel::Size;
2482     my $ps = FileHandle->new;
2483     open $ps, "/proc/$$/status";
2484     my $vm = 0;
2485     while (<$ps>) {
2486         next unless /VmSize:\s+(\d+)/;
2487         $vm = $1;
2488         last;
2489     }
2490     $CPAN::Frontend->mywarn(sprintf(
2491                                     "%-27s %6d\n%-27s %6d\n",
2492                                     "vm",
2493                                     $vm,
2494                                     "CPAN::META",
2495                                     Devel::Size::total_size($CPAN::META)/1024,
2496                                    ));
2497     for my $k (sort keys %$CPAN::META) {
2498         next unless substr($k,0,4) eq "read";
2499         warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
2500         for my $k2 (sort keys %{$CPAN::META->{$k}}) {
2501             warn sprintf "  %-25s %6d (keys: %6d)\n",
2502                 $k2,
2503                     Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
2504                           scalar keys %{$CPAN::META->{$k}{$k2}};
2505         }
2506     }
2507 }
2508
2509 # compare with install_tested
2510 #-> sub CPAN::Shell::is_tested
2511 sub is_tested {
2512     my($self) = @_;
2513     CPAN::Index->reload;
2514     for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
2515         my $time;
2516         if ($CPAN::META->{is_tested}{$b}) {
2517             $time = scalar(localtime $CPAN::META->{is_tested}{$b});
2518         } else {
2519             $time = scalar localtime;
2520             $time =~ s/\S/?/g;
2521         }
2522         $CPAN::Frontend->myprint(sprintf "%s %s\n", $time, $b);
2523     }
2524 }
2525
2526 #-> sub CPAN::Shell::autobundle ;
2527 sub autobundle {
2528     my($self) = shift;
2529     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
2530     my(@bundle) = $self->_u_r_common("a",@_);
2531     my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
2532     File::Path::mkpath($todir);
2533     unless (-d $todir) {
2534         $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
2535         return;
2536     }
2537     my($y,$m,$d) =  (localtime)[5,4,3];
2538     $y+=1900;
2539     $m++;
2540     my($c) = 0;
2541     my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
2542     my($to) = File::Spec->catfile($todir,"$me.pm");
2543     while (-f $to) {
2544         $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
2545         $to = File::Spec->catfile($todir,"$me.pm");
2546     }
2547     my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
2548     $fh->print(
2549                "package Bundle::$me;\n\n",
2550                "\$VERSION = '0.01';\n\n",
2551                "1;\n\n",
2552                "__END__\n\n",
2553                "=head1 NAME\n\n",
2554                "Bundle::$me - Snapshot of installation on ",
2555                $Config::Config{'myhostname'},
2556                " on ",
2557                scalar(localtime),
2558                "\n\n=head1 SYNOPSIS\n\n",
2559                "perl -MCPAN -e 'install Bundle::$me'\n\n",
2560                "=head1 CONTENTS\n\n",
2561                join("\n", @bundle),
2562                "\n\n=head1 CONFIGURATION\n\n",
2563                Config->myconfig,
2564                "\n\n=head1 AUTHOR\n\n",
2565                "This Bundle has been generated automatically ",
2566                "by the autobundle routine in CPAN.pm.\n",
2567               );
2568     $fh->close;
2569     $CPAN::Frontend->myprint("\nWrote bundle file
2570     $to\n\n");
2571 }
2572
2573 #-> sub CPAN::Shell::expandany ;
2574 sub expandany {
2575     my($self,$s) = @_;
2576     CPAN->debug("s[$s]") if $CPAN::DEBUG;
2577     if ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory
2578         $s = CPAN::Distribution->normalize($s);
2579         return $CPAN::META->instance('CPAN::Distribution',$s);
2580         # Distributions spring into existence, not expand
2581     } elsif ($s =~ m|^Bundle::|) {
2582         $self->local_bundles; # scanning so late for bundles seems
2583                               # both attractive and crumpy: always
2584                               # current state but easy to forget
2585                               # somewhere
2586         return $self->expand('Bundle',$s);
2587     } else {
2588         return $self->expand('Module',$s)
2589             if $CPAN::META->exists('CPAN::Module',$s);
2590     }
2591     return;
2592 }
2593
2594 #-> sub CPAN::Shell::expand ;
2595 sub expand {
2596     my $self = shift;
2597     my($type,@args) = @_;
2598     CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
2599     my $class = "CPAN::$type";
2600     my $methods = ['id'];
2601     for my $meth (qw(name)) {
2602         next unless $class->can($meth);
2603         push @$methods, $meth;
2604     }
2605     $self->expand_by_method($class,$methods,@args);
2606 }
2607
2608 #-> sub CPAN::Shell::expand_by_method ;
2609 sub expand_by_method {
2610     my $self = shift;
2611     my($class,$methods,@args) = @_;
2612     my($arg,@m);
2613     for $arg (@args) {
2614         my($regex,$command);
2615         if ($arg =~ m|^/(.*)/$|) {
2616             $regex = $1;
2617         } elsif ($arg =~ m/=/) {
2618             $command = 1;
2619         }
2620         my $obj;
2621         CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
2622                     $class,
2623                     defined $regex ? $regex : "UNDEFINED",
2624                     defined $command ? $command : "UNDEFINED",
2625                    ) if $CPAN::DEBUG;
2626         if (defined $regex) {
2627             if (CPAN::_sqlite_running) {
2628                 $CPAN::SQLite->search($class, $regex);
2629             }
2630             for $obj (
2631                       $CPAN::META->all_objects($class)
2632                      ) {
2633                 unless ($obj && UNIVERSAL::can($obj,"id") && $obj->id){
2634                     # BUG, we got an empty object somewhere
2635                     require Data::Dumper;
2636                     CPAN->debug(sprintf(
2637                                         "Bug in CPAN: Empty id on obj[%s][%s]",
2638                                         $obj,
2639                                         Data::Dumper::Dumper($obj)
2640                                        )) if $CPAN::DEBUG;
2641                     next;
2642                 }
2643                 for my $method (@$methods) {
2644                     my $match = eval {$obj->$method() =~ /$regex/i};
2645                     if ($@) {
2646                         my($err) = $@ =~ /^(.+) at .+? line \d+\.$/;
2647                         $err ||= $@; # if we were too restrictive above
2648                         $CPAN::Frontend->mydie("$err\n");
2649                     } elsif ($match) {
2650                         push @m, $obj;
2651                         last;
2652                     }
2653                 }
2654             }
2655         } elsif ($command) {
2656             die "equal sign in command disabled (immature interface), ".
2657                 "you can set
2658  ! \$CPAN::Shell::ADVANCED_QUERY=1
2659 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
2660 that may go away anytime.\n"
2661                     unless $ADVANCED_QUERY;
2662             my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
2663             my($matchcrit) = $criterion =~ m/^~(.+)/;
2664             for my $self (
2665                           sort
2666                           {$a->id cmp $b->id}
2667                           $CPAN::META->all_objects($class)
2668                          ) {
2669                 my $lhs = $self->$method() or next; # () for 5.00503
2670                 if ($matchcrit) {
2671                     push @m, $self if $lhs =~ m/$matchcrit/;
2672                 } else {
2673                     push @m, $self if $lhs eq $criterion;
2674                 }
2675             }
2676         } else {
2677             my($xarg) = $arg;
2678             if ( $class eq 'CPAN::Bundle' ) {
2679                 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
2680             } elsif ($class eq "CPAN::Distribution") {
2681                 $xarg = CPAN::Distribution->normalize($arg);
2682             } else {
2683                 $xarg =~ s/:+/::/g;
2684             }
2685             if ($CPAN::META->exists($class,$xarg)) {
2686                 $obj = $CPAN::META->instance($class,$xarg);
2687             } elsif ($CPAN::META->exists($class,$arg)) {
2688                 $obj = $CPAN::META->instance($class,$arg);
2689             } else {
2690                 next;
2691             }
2692             push @m, $obj;
2693         }
2694     }
2695     @m = sort {$a->id cmp $b->id} @m;
2696     if ( $CPAN::DEBUG ) {
2697         my $wantarray = wantarray;
2698         my $join_m = join ",", map {$_->id} @m;
2699         $self->debug("wantarray[$wantarray]join_m[$join_m]");
2700     }
2701     return wantarray ? @m : $m[0];
2702 }
2703
2704 #-> sub CPAN::Shell::format_result ;
2705 sub format_result {
2706     my($self) = shift;
2707     my($type,@args) = @_;
2708     @args = '/./' unless @args;
2709     my(@result) = $self->expand($type,@args);
2710     my $result = @result == 1 ?
2711         $result[0]->as_string :
2712             @result == 0 ?
2713                 "No objects of type $type found for argument @args\n" :
2714                     join("",
2715                          (map {$_->as_glimpse} @result),
2716                          scalar @result, " items found\n",
2717                         );
2718     $result;
2719 }
2720
2721 #-> sub CPAN::Shell::report_fh ;
2722 {
2723     my $installation_report_fh;
2724     my $previously_noticed = 0;
2725
2726     sub report_fh {
2727         return $installation_report_fh if $installation_report_fh;
2728         if ($CPAN::META->has_inst("File::Temp")) {
2729             $installation_report_fh
2730                 = File::Temp->new(
2731                                   template => 'cpan_install_XXXX',
2732                                   suffix   => '.txt',
2733                                   unlink   => 0,
2734                                  );
2735         }
2736         unless ( $installation_report_fh ) {
2737             warn("Couldn't open installation report file; " .
2738                  "no report file will be generated."
2739                 ) unless $previously_noticed++;
2740         }
2741     }
2742 }
2743
2744
2745 # The only reason for this method is currently to have a reliable
2746 # debugging utility that reveals which output is going through which
2747 # channel. No, I don't like the colors ;-)
2748
2749 # to turn colordebugging on, write
2750 # cpan> o conf colorize_output 1
2751
2752 #-> sub CPAN::Shell::print_ornamented ;
2753 {
2754     my $print_ornamented_have_warned = 0;
2755     sub colorize_output {
2756         my $colorize_output = $CPAN::Config->{colorize_output};
2757         if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
2758             unless ($print_ornamented_have_warned++) {
2759                 # no myprint/mywarn within myprint/mywarn!
2760                 warn "Colorize_output is set to true but Term::ANSIColor is not
2761 installed. To activate colorized output, please install Term::ANSIColor.\n\n";
2762             }
2763             $colorize_output = 0;
2764         }
2765         return $colorize_output;
2766     }
2767 }
2768
2769
2770 #-> sub CPAN::Shell::print_ornamented ;
2771 sub print_ornamented {
2772     my($self,$what,$ornament) = @_;
2773     return unless defined $what;
2774
2775     local $| = 1; # Flush immediately
2776     if ( $CPAN::Be_Silent ) {
2777         print {report_fh()} $what;
2778         return;
2779     }
2780     my $swhat = "$what"; # stringify if it is an object
2781     if ($CPAN::Config->{term_is_latin}){
2782         # courtesy jhi:
2783         $swhat
2784             =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
2785     }
2786     if ($self->colorize_output) {
2787         if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
2788             # if you want to have this configurable, please file a bugreport
2789             $ornament = $CPAN::Config->{colorize_debug} || "black on_cyan";
2790         }
2791         my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
2792         if ($@) {
2793             print "Term::ANSIColor rejects color[$ornament]: $@\n
2794 Please choose a different color (Hint: try 'o conf init /color/')\n";
2795         }
2796         print $color_on,
2797             $swhat,
2798                 Term::ANSIColor::color("reset");
2799     } else {
2800         print $swhat;
2801     }
2802 }
2803
2804 #-> sub CPAN::Shell::myprint ;
2805
2806 # where is myprint/mywarn/Frontend/etc. documented? We need guidelines
2807 # where to use what! I think, we send everything to STDOUT and use
2808 # print for normal/good news and warn for news that need more
2809 # attention. Yes, this is our working contract for now.
2810 sub myprint {
2811     my($self,$what) = @_;
2812
2813     $self->print_ornamented($what, $CPAN::Config->{colorize_print}||'bold blue on_white');
2814 }
2815
2816 #-> sub CPAN::Shell::myexit ;
2817 sub myexit {
2818     my($self,$what) = @_;
2819     $self->myprint($what);
2820     exit;
2821 }
2822
2823 #-> sub CPAN::Shell::mywarn ;
2824 sub mywarn {
2825     my($self,$what) = @_;
2826     $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
2827 }
2828
2829 # only to be used for shell commands
2830 #-> sub CPAN::Shell::mydie ;
2831 sub mydie {
2832     my($self,$what) = @_;
2833     $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
2834
2835     # If it is the shell, we want that the following die to be silent,
2836     # but if it is not the shell, we would need a 'die $what'. We need
2837     # to take care that only shell commands use mydie. Is this
2838     # possible?
2839
2840     die "\n";
2841 }
2842
2843 # sub CPAN::Shell::colorable_makemaker_prompt ;
2844 sub colorable_makemaker_prompt {
2845     my($foo,$bar) = @_;
2846     if (CPAN::Shell->colorize_output) {
2847         my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
2848         my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
2849         print $color_on;
2850     }
2851     my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
2852     if (CPAN::Shell->colorize_output) {
2853         print Term::ANSIColor::color('reset');
2854     }
2855     return $ans;
2856 }
2857
2858 # use this only for unrecoverable errors!
2859 #-> sub CPAN::Shell::unrecoverable_error ;
2860 sub unrecoverable_error {
2861     my($self,$what) = @_;
2862     my @lines = split /\n/, $what;
2863     my $longest = 0;
2864     for my $l (@lines) {
2865         $longest = length $l if length $l > $longest;
2866     }
2867     $longest = 62 if $longest > 62;
2868     for my $l (@lines) {
2869         if ($l =~ /^\s*$/){
2870             $l = "\n";
2871             next;
2872         }
2873         $l = "==> $l";
2874         if (length $l < 66) {
2875             $l = pack "A66 A*", $l, "<==";
2876         }
2877         $l .= "\n";
2878     }
2879     unshift @lines, "\n";
2880     $self->mydie(join "", @lines);
2881 }
2882
2883 #-> sub CPAN::Shell::mysleep ;
2884 sub mysleep {
2885     my($self, $sleep) = @_;
2886     use Time::HiRes qw(sleep);
2887     sleep $sleep;
2888 }
2889
2890 #-> sub CPAN::Shell::setup_output ;
2891 sub setup_output {
2892     return if -t STDOUT;
2893     my $odef = select STDERR;
2894     $| = 1;
2895     select STDOUT;
2896     $| = 1;
2897     select $odef;
2898 }
2899
2900 #-> sub CPAN::Shell::rematein ;
2901 # RE-adme||MA-ke||TE-st||IN-stall : nearly everything runs through here
2902 sub rematein {
2903     my $self = shift;
2904     my($meth,@some) = @_;
2905     my @pragma;
2906     while($meth =~ /^(ff?orce|notest)$/) {
2907         push @pragma, $meth;
2908         $meth = shift @some or
2909             $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
2910                                    "cannot continue");
2911     }
2912     setup_output();
2913     CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
2914
2915     # Here is the place to set "test_count" on all involved parties to
2916     # 0. We then can pass this counter on to the involved
2917     # distributions and those can refuse to test if test_count > X. In
2918     # the first stab at it we could use a 1 for "X".
2919
2920     # But when do I reset the distributions to start with 0 again?
2921     # Jost suggested to have a random or cycling interaction ID that
2922     # we pass through. But the ID is something that is just left lying
2923     # around in addition to the counter, so I'd prefer to set the
2924     # counter to 0 now, and repeat at the end of the loop. But what
2925     # about dependencies? They appear later and are not reset, they
2926     # enter the queue but not its copy. How do they get a sensible
2927     # test_count?
2928
2929     my $needs_recursion_protection = "make|test|install";
2930
2931     # construct the queue
2932     my($s,@s,@qcopy);
2933   STHING: foreach $s (@some) {
2934         my $obj;
2935         if (ref $s) {
2936             CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
2937             $obj = $s;
2938         } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
2939         } elsif ($s =~ m|^/|) { # looks like a regexp
2940             if (substr($s,-1,1) eq ".") {
2941                 $obj = CPAN::Shell->expandany($s);
2942             } else {
2943                 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
2944                                         "not supported.\nRejecting argument '$s'\n");
2945                 $CPAN::Frontend->mysleep(2);
2946                 next;
2947             }
2948         } elsif ($meth eq "ls") {
2949             $self->globls($s,\@pragma);
2950             next STHING;
2951         } else {
2952             CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
2953             $obj = CPAN::Shell->expandany($s);
2954         }
2955         if (0) {
2956         } elsif (ref $obj) {
2957             if ($meth =~ /^($needs_recursion_protection)$/) {
2958                 # silly for look or dump
2959                 $obj->color_cmd_tmps(0,1);
2960             }
2961             CPAN::Queue->new(qmod => $obj->id, reqtype => "c");
2962             push @qcopy, $obj;
2963         } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
2964             $obj = $CPAN::META->instance('CPAN::Author',uc($s));
2965             if ($meth =~ /^(dump|ls)$/) {
2966                 $obj->$meth();
2967             } else {
2968                 $CPAN::Frontend->mywarn(
2969                                         join "",
2970                                         "Don't be silly, you can't $meth ",
2971                                         $obj->fullname,
2972                                         " ;-)\n"
2973                                        );
2974                 $CPAN::Frontend->mysleep(2);
2975             }
2976         } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
2977             CPAN::InfoObj->dump($s);
2978         } else {
2979             $CPAN::Frontend
2980                 ->mywarn(qq{Warning: Cannot $meth $s, }.
2981                           qq{don't know what it is.
2982 Try the command
2983
2984     i /$s/
2985
2986 to find objects with matching identifiers.
2987 });
2988             $CPAN::Frontend->mysleep(2);
2989         }
2990     }
2991
2992     # queuerunner (please be warned: when I started to change the
2993     # queue to hold objects instead of names, I made one or two
2994     # mistakes and never found which. I reverted back instead)
2995     while (my $q = CPAN::Queue->first) {
2996         my $obj;
2997         my $s = $q->as_string;
2998         my $reqtype = $q->reqtype || "";
2999         $obj = CPAN::Shell->expandany($s);
3000         unless ($obj) {
3001             # don't know how this can happen, maybe we should panic,
3002             # but maybe we get a solution from the first user who hits
3003             # this unfortunate exception?
3004             $CPAN::Frontend->mywarn("Warning: Could not expand string '$s' ".
3005                                     "to an object. Skipping.");
3006             $CPAN::Frontend->mysleep(5);
3007             next;
3008         }
3009         $obj->{reqtype} ||= "";
3010         {
3011             # force debugging because CPAN::SQLite somehow delivers us
3012             # an empty object;
3013
3014             # local $CPAN::DEBUG = 1024; # Shell; probably fixed now
3015
3016             CPAN->debug("s[$s]obj-reqtype[$obj->{reqtype}]".
3017                         "q-reqtype[$reqtype]") if $CPAN::DEBUG;
3018         }
3019         if ($obj->{reqtype}) {
3020             if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
3021                 $obj->{reqtype} = $reqtype;
3022                 if (
3023                     exists $obj->{install}
3024                     &&
3025                     (
3026                      UNIVERSAL::can($obj->{install},"failed") ?
3027                      $obj->{install}->failed :
3028                      $obj->{install} =~ /^NO/
3029                     )
3030                    ) {
3031                     delete $obj->{install};
3032                     $CPAN::Frontend->mywarn
3033                         ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
3034                 }
3035             }
3036         } else {
3037             $obj->{reqtype} = $reqtype;
3038         }
3039
3040         for my $pragma (@pragma) {
3041             if ($pragma
3042                 &&
3043                 $obj->can($pragma)){
3044                 $obj->$pragma($meth);
3045             }
3046         }
3047         if (UNIVERSAL::can($obj, 'called_for')) {
3048             $obj->called_for($s);
3049         }
3050         CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
3051                     qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
3052
3053         push @qcopy, $obj;
3054         if (! UNIVERSAL::can($obj,$meth)) {
3055             # Must never happen
3056             my $serialized = "";
3057             if (0) {
3058             } elsif ($CPAN::META->has_inst("YAML::Syck")) {
3059                 $serialized = YAML::Syck::Dump($obj);
3060             } elsif ($CPAN::META->has_inst("YAML")) {
3061                 $serialized = YAML::Dump($obj);
3062             } elsif ($CPAN::META->has_inst("Data::Dumper")) {
3063                 $serialized = Data::Dumper::Dumper($obj);
3064             } else {
3065                 require overload;
3066                 $serialized = overload::StrVal($obj);
3067             }
3068             $CPAN::Frontend->mydie("Panic: obj[$serialized] cannot meth[$meth]");
3069         } elsif ($obj->$meth()){
3070             CPAN::Queue->delete($s);
3071         } else {
3072             CPAN->debug("failed");
3073         }
3074
3075         $obj->undelay;
3076         for my $pragma (@pragma) {
3077             my $unpragma = "un$pragma";
3078             if ($obj->can($unpragma)) {
3079                 $obj->$unpragma();
3080             }
3081         }
3082         CPAN::Queue->delete_first($s);
3083     }
3084     if ($meth =~ /^($needs_recursion_protection)$/) {
3085         for my $obj (@qcopy) {
3086             $obj->color_cmd_tmps(0,0);
3087         }
3088     }
3089 }
3090
3091 #-> sub CPAN::Shell::recent ;
3092 sub recent {
3093   my($self) = @_;
3094
3095   CPAN::Distribution::_display_url( $self, $CPAN::Defaultrecent );
3096   return;
3097 }
3098
3099 {
3100     # set up the dispatching methods
3101     no strict "refs";
3102     for my $command (qw(
3103                         clean
3104                         cvs_import
3105                         dump
3106                         force
3107                         fforce
3108                         get
3109                         install
3110                         look
3111                         ls
3112                         make
3113                         notest
3114                         perldoc
3115                         readme
3116                         test
3117                        )) {
3118         *$command = sub { shift->rematein($command, @_); };
3119     }
3120 }
3121
3122 package CPAN::LWP::UserAgent;
3123 use strict;
3124
3125 sub config {
3126     return if $SETUPDONE;
3127     if ($CPAN::META->has_usable('LWP::UserAgent')) {
3128         require LWP::UserAgent;
3129         @ISA = qw(Exporter LWP::UserAgent);
3130         $SETUPDONE++;
3131     } else {
3132         $CPAN::Frontend->mywarn("  LWP::UserAgent not available\n");
3133     }
3134 }
3135
3136 sub get_basic_credentials {
3137     my($self, $realm, $uri, $proxy) = @_;
3138     if ($USER && $PASSWD) {
3139         return ($USER, $PASSWD);
3140     }
3141     if ( $proxy ) {
3142         ($USER,$PASSWD) = $self->get_proxy_credentials();
3143     } else {
3144         ($USER,$PASSWD) = $self->get_non_proxy_credentials();
3145     }
3146     return($USER,$PASSWD);
3147 }
3148
3149 sub get_proxy_credentials {
3150     my $self = shift;
3151     my ($user, $password);
3152     if ( defined $CPAN::Config->{proxy_user} &&
3153          defined $CPAN::Config->{proxy_pass}) {
3154         $user = $CPAN::Config->{proxy_user};
3155         $password = $CPAN::Config->{proxy_pass};
3156         return ($user, $password);
3157     }
3158     my $username_prompt = "\nProxy authentication needed!
3159  (Note: to permanently configure username and password run
3160    o conf proxy_user your_username
3161    o conf proxy_pass your_password
3162      )\nUsername:";
3163     ($user, $password) =
3164         _get_username_and_password_from_user($username_prompt);
3165     return ($user,$password);
3166 }
3167
3168 sub get_non_proxy_credentials {
3169     my $self = shift;
3170     my ($user,$password);
3171     if ( defined $CPAN::Config->{username} &&
3172          defined $CPAN::Config->{password}) {
3173         $user = $CPAN::Config->{username};
3174         $password = $CPAN::Config->{password};
3175         return ($user, $password);
3176     }
3177     my $username_prompt = "\nAuthentication needed!
3178      (Note: to permanently configure username and password run
3179        o conf username your_username
3180        o conf password your_password
3181      )\nUsername:";
3182
3183     ($user, $password) =
3184         _get_username_and_password_from_user($username_prompt);
3185     return ($user,$password);
3186 }
3187
3188 sub _get_username_and_password_from_user {
3189     my $username_message = shift;
3190     my ($username,$password);
3191
3192     ExtUtils::MakeMaker->import(qw(prompt));
3193     $username = prompt($username_message);
3194         if ($CPAN::META->has_inst("Term::ReadKey")) {
3195             Term::ReadKey::ReadMode("noecho");
3196         }
3197     else {
3198         $CPAN::Frontend->mywarn(
3199             "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"
3200         );
3201     }
3202     $password = prompt("Password:");
3203
3204         if ($CPAN::META->has_inst("Term::ReadKey")) {
3205             Term::ReadKey::ReadMode("restore");
3206         }
3207         $CPAN::Frontend->myprint("\n\n");
3208     return ($username,$password);
3209 }
3210
3211 # mirror(): Its purpose is to deal with proxy authentication. When we
3212 # call SUPER::mirror, we relly call the mirror method in
3213 # LWP::UserAgent. LWP::UserAgent will then call
3214 # $self->get_basic_credentials or some equivalent and this will be
3215 # $self->dispatched to our own get_basic_credentials method.
3216
3217 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3218
3219 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3220 # although we have gone through our get_basic_credentials, the proxy
3221 # server refuses to connect. This could be a case where the username or
3222 # password has changed in the meantime, so I'm trying once again without
3223 # $USER and $PASSWD to give the get_basic_credentials routine another
3224 # chance to set $USER and $PASSWD.
3225
3226 # mirror(): Its purpose is to deal with proxy authentication. When we
3227 # call SUPER::mirror, we relly call the mirror method in
3228 # LWP::UserAgent. LWP::UserAgent will then call
3229 # $self->get_basic_credentials or some equivalent and this will be
3230 # $self->dispatched to our own get_basic_credentials method.
3231
3232 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3233
3234 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3235 # although we have gone through our get_basic_credentials, the proxy
3236 # server refuses to connect. This could be a case where the username or
3237 # password has changed in the meantime, so I'm trying once again without
3238 # $USER and $PASSWD to give the get_basic_credentials routine another
3239 # chance to set $USER and $PASSWD.
3240
3241 sub mirror {
3242     my($self,$url,$aslocal) = @_;
3243     my $result = $self->SUPER::mirror($url,$aslocal);
3244     if ($result->code == 407) {
3245         undef $USER;
3246         undef $PASSWD;
3247         $result = $self->SUPER::mirror($url,$aslocal);
3248     }
3249     $result;
3250 }
3251
3252 package CPAN::FTP;
3253 use strict;
3254
3255 #-> sub CPAN::FTP::ftp_statistics
3256 # if they want to rewrite, they need to pass in a filehandle
3257 sub _ftp_statistics {
3258     my($self,$fh) = @_;
3259     my $locktype = $fh ? LOCK_EX : LOCK_SH;
3260     $fh ||= FileHandle->new;
3261     my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3262     open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!");
3263     my $sleep = 1;
3264     my $waitstart;
3265     while (!flock $fh, $locktype|LOCK_NB) {
3266         $waitstart ||= localtime();
3267         if ($sleep>3) {
3268             $CPAN::Frontend->mywarn("Waiting for a read lock on '$file' (since $waitstart)\n");
3269         }
3270         $CPAN::Frontend->mysleep($sleep);
3271         if ($sleep <= 3) {
3272             $sleep+=0.33;
3273         } elsif ($sleep <=6) {
3274             $sleep+=0.11;
3275         }
3276     }
3277     my $stats = eval { CPAN->_yaml_loadfile($file); };
3278     if ($@) {
3279         if (ref $@) {
3280             if (ref $@ eq "CPAN::Exception::yaml_not_installed") {
3281                 $CPAN::Frontend->myprint("Warning (usually harmless): $@");
3282                 return;
3283             } elsif (ref $@ eq "CPAN::Exception::yaml_process_error") {
3284                 $CPAN::Frontend->mydie($@);
3285             }
3286         } else {
3287             $CPAN::Frontend->mydie($@);
3288         }
3289     }
3290     return $stats->[0];
3291 }
3292
3293 #-> sub CPAN::FTP::_mytime
3294 sub _mytime () {
3295     if (CPAN->has_inst("Time::HiRes")) {
3296         return Time::HiRes::time();
3297     } else {
3298         return time;
3299     }
3300 }
3301
3302 #-> sub CPAN::FTP::_new_stats
3303 sub _new_stats {
3304     my($self,$file) = @_;
3305     my $ret = {
3306                file => $file,
3307                attempts => [],
3308                start => _mytime,
3309               };
3310     $ret;
3311 }
3312
3313 #-> sub CPAN::FTP::_add_to_statistics
3314 sub _add_to_statistics {
3315     my($self,$stats) = @_;
3316     my $yaml_module = CPAN::_yaml_module;
3317     $self->debug("yaml_module[$yaml_module]") if $CPAN::DEBUG;
3318     if ($CPAN::META->has_inst($yaml_module)) {
3319         $stats->{thesiteurl} = $ThesiteURL;
3320         if (CPAN->has_inst("Time::HiRes")) {
3321             $stats->{end} = Time::HiRes::time();
3322         } else {
3323             $stats->{end} = time;
3324         }
3325         my $fh = FileHandle->new;
3326         my $time = time;
3327         my $sdebug = 0;
3328         my @debug;
3329         @debug = $time if $sdebug;
3330         my $fullstats = $self->_ftp_statistics($fh);
3331         close $fh;
3332         $fullstats->{history} ||= [];
3333         push @debug, scalar @{$fullstats->{history}} if $sdebug;
3334         push @debug, time if $sdebug;
3335         push @{$fullstats->{history}}, $stats;
3336         # arbitrary hardcoded constants until somebody demands to have
3337         # them settable; YAML.pm 0.62 is unacceptably slow with 999;
3338         # YAML::Syck 0.82 has no noticable performance problem with 999;
3339         while (
3340                @{$fullstats->{history}} > 99
3341                || $time - $fullstats->{history}[0]{start} > 14*86400
3342               ) {
3343             shift @{$fullstats->{history}}
3344         }
3345         push @debug, scalar @{$fullstats->{history}} if $sdebug;
3346         push @debug, time if $sdebug;
3347         push @debug, scalar localtime($fullstats->{history}[0]{start}) if $sdebug;
3348         # need no eval because if this fails, it is serious
3349         my $sfile = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3350         CPAN->_yaml_dumpfile("$sfile.$$",$fullstats);
3351         if ( $sdebug||$CPAN::DEBUG ) {
3352             local $CPAN::DEBUG = 512; # FTP
3353             push @debug, time;
3354             CPAN->debug(sprintf("DEBUG history: before_read[%d]before[%d]at[%d]".
3355                                 "after[%d]at[%d]oldest[%s]dumped backat[%d]",
3356                                 @debug,
3357                                ));
3358         }
3359         # Win32 cannot rename a file to an existing filename
3360         unlink($sfile) if ($^O eq 'MSWin32');
3361         rename "$sfile.$$", $sfile
3362             or $CPAN::Frontend->mydie("Could not rename '$sfile.$$' to '$sfile': $!\n");
3363     }
3364 }
3365
3366 # if file is CHECKSUMS, suggest the place where we got the file to be
3367 # checked from, maybe only for young files?
3368 #-> sub CPAN::FTP::_recommend_url_for
3369 sub _recommend_url_for {
3370     my($self, $file) = @_;
3371     my $urllist = $self->_get_urllist;
3372     if ($file =~ s|/CHECKSUMS(.gz)?$||) {
3373         my $fullstats = $self->_ftp_statistics();
3374         my $history = $fullstats->{history} || [];
3375         while (my $last = pop @$history) {
3376             last if $last->{end} - time > 3600; # only young results are interesting
3377             next unless $last->{file}; # dirname of nothing dies!
3378             next unless $file eq File::Basename::dirname($last->{file});
3379             return $last->{thesiteurl};
3380         }
3381     }
3382     if ($CPAN::Config->{randomize_urllist}
3383         &&
3384         rand(1) < $CPAN::Config->{randomize_urllist}
3385        ) {
3386         $urllist->[int rand scalar @$urllist];
3387     } else {
3388         return ();
3389     }
3390 }
3391
3392 #-> sub CPAN::FTP::_get_urllist
3393 sub _get_urllist {
3394     my($self) = @_;
3395     $CPAN::Config->{urllist} ||= [];
3396     unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
3397         $CPAN::Frontend->mywarn("Malformed urllist; ignoring.  Configuration file corrupt?\n");
3398         $CPAN::Config->{urllist} = [];
3399     }
3400     my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}};
3401     for my $u (@urllist) {
3402         CPAN->debug("u[$u]") if $CPAN::DEBUG;
3403         if (UNIVERSAL::can($u,"text")) {
3404             $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
3405         } else {
3406             $u .= "/" unless substr($u,-1) eq "/";
3407             $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
3408         }
3409     }
3410     \@urllist;
3411 }
3412
3413 #-> sub CPAN::FTP::ftp_get ;
3414 sub ftp_get {
3415     my($class,$host,$dir,$file,$target) = @_;
3416     $class->debug(
3417                   qq[Going to fetch file [$file] from dir [$dir]
3418         on host [$host] as local [$target]\n]
3419                  ) if $CPAN::DEBUG;
3420     my $ftp = Net::FTP->new($host);
3421     unless ($ftp) {
3422         $CPAN::Frontend->mywarn("  Could not connect to host '$host' with Net::FTP\n");
3423         return;
3424     }
3425     return 0 unless defined $ftp;
3426     $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
3427     $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
3428     unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
3429         my $msg = $ftp->message;
3430         $CPAN::Frontend->mywarn("  Couldn't login on $host: $msg");
3431         return;
3432     }
3433     unless ( $ftp->cwd($dir) ){
3434         my $msg = $ftp->message;
3435         $CPAN::Frontend->mywarn("  Couldn't cwd $dir: $msg");
3436         return;
3437     }
3438     $ftp->binary;
3439     $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
3440     unless ( $ftp->get($file,$target) ){
3441         my $msg = $ftp->message;
3442         $CPAN::Frontend->mywarn("  Couldn't fetch $file from $host: $msg");
3443         return;
3444     }
3445     $ftp->quit; # it's ok if this fails
3446     return 1;
3447 }
3448
3449 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
3450
3451  # > *** /install/perl/live/lib/CPAN.pm-        Wed Sep 24 13:08:48 1997
3452  # > --- /tmp/cp        Wed Sep 24 13:26:40 1997
3453  # > ***************
3454  # > *** 1562,1567 ****
3455  # > --- 1562,1580 ----
3456  # >       return 1 if substr($url,0,4) eq "file";
3457  # >       return 1 unless $url =~ m|://([^/]+)|;
3458  # >       my $host = $1;
3459  # > +     my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
3460  # > +     if ($proxy) {
3461  # > +         $proxy =~ m|://([^/:]+)|;
3462  # > +         $proxy = $1;
3463  # > +         my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
3464  # > +         if ($noproxy) {
3465  # > +             if ($host !~ /$noproxy$/) {
3466  # > +                 $host = $proxy;
3467  # > +             }
3468  # > +         } else {
3469  # > +             $host = $proxy;
3470  # > +         }
3471  # > +     }
3472  # >       require Net::Ping;
3473  # >       return 1 unless $Net::Ping::VERSION >= 2;
3474  # >       my $p;
3475
3476
3477 #-> sub CPAN::FTP::localize ;
3478 sub localize {
3479     my($self,$file,$aslocal,$force) = @_;
3480     $force ||= 0;
3481     Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
3482         unless defined $aslocal;
3483     $self->debug("file[$file] aslocal[$aslocal] force[$force]")
3484         if $CPAN::DEBUG;
3485
3486     if ($^O eq 'MacOS') {
3487         # Comment by AK on 2000-09-03: Uniq short filenames would be
3488         # available in CHECKSUMS file
3489         my($name, $path) = File::Basename::fileparse($aslocal, '');
3490         if (length($name) > 31) {
3491             $name =~ s/(
3492                         \.(
3493                            readme(\.(gz|Z))? |
3494                            (tar\.)?(gz|Z) |
3495                            tgz |
3496                            zip |
3497                            pm\.(gz|Z)
3498                           )
3499                        )$//x;
3500             my $suf = $1;
3501             my $size = 31 - length($suf);
3502             while (length($name) > $size) {
3503                 chop $name;
3504             }
3505             $name .= $suf;
3506             $aslocal = File::Spec->catfile($path, $name);
3507         }
3508     }
3509
3510     if (-f $aslocal && -r _ && !($force & 1)){
3511         my $size;
3512         if ($size = -s $aslocal) {
3513             $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
3514             return $aslocal;
3515         } else {
3516             # empty file from a previous unsuccessful attempt to download it
3517             unlink $aslocal or
3518                 $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
3519                                        "could not remove.");
3520         }
3521     }
3522     my($maybe_restore) = 0;
3523     if (-f $aslocal){
3524         rename $aslocal, "$aslocal.bak$$";
3525         $maybe_restore++;
3526     }
3527
3528     my($aslocal_dir) = File::Basename::dirname($aslocal);
3529     File::Path::mkpath($aslocal_dir);
3530     $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
3531         qq{directory "$aslocal_dir".
3532     I\'ll continue, but if you encounter problems, they may be due
3533     to insufficient permissions.\n}) unless -w $aslocal_dir;
3534
3535     # Inheritance is not easier to manage than a few if/else branches
3536     if ($CPAN::META->has_usable('LWP::UserAgent')) {
3537         unless ($Ua) {
3538             CPAN::LWP::UserAgent->config;
3539             eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
3540             if ($@) {
3541                 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
3542                     if $CPAN::DEBUG;
3543             } else {
3544                 my($var);
3545                 $Ua->proxy('ftp',  $var)
3546                     if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
3547                 $Ua->proxy('http', $var)
3548                     if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
3549
3550
3551 # >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
3552 #
3553 #  > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
3554 #  > use ones that require basic autorization.
3555 #
3556 #  > Example of when I use it manually in my own stuff:
3557 #
3558 #  > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
3559 #  > $req->proxy_authorization_basic("username","password");
3560 #  > $res = $ua->request($req);
3561 #
3562
3563                 $Ua->no_proxy($var)
3564                     if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
3565             }
3566         }
3567     }
3568     for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
3569         $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
3570     }
3571
3572     # Try the list of urls for each single object. We keep a record
3573     # where we did get a file from
3574     my(@reordered,$last);
3575     my $ccurllist = $self->_get_urllist;
3576     $last = $#$ccurllist;
3577     if ($force & 2) { # local cpans probably out of date, don't reorder
3578         @reordered = (0..$last);
3579     } else {
3580         @reordered =
3581             sort {
3582                 (substr($ccurllist->[$b],0,4) eq "file")
3583                     <=>
3584                 (substr($ccurllist->[$a],0,4) eq "file")
3585                     or
3586                 defined($ThesiteURL)
3587                     and
3588                 ($ccurllist->[$b] eq $ThesiteURL)
3589                     <=>
3590                 ($ccurllist->[$a] eq $ThesiteURL)
3591             } 0..$last;
3592     }
3593     my(@levels);
3594     $Themethod ||= "";
3595     $self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG;
3596     if ($Themethod) {
3597         @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
3598     } else {
3599         @levels = qw/easy hard hardest/;
3600     }
3601     @levels = qw/easy/ if $^O eq 'MacOS';
3602     my($levelno);
3603     local $ENV{FTP_PASSIVE} =
3604         exists $CPAN::Config->{ftp_passive} ?
3605         $CPAN::Config->{ftp_passive} : 1;
3606     my $ret;
3607     my $stats = $self->_new_stats($file);
3608   LEVEL: for $levelno (0..$#levels) {
3609         my $level = $levels[$levelno];
3610         my $method = "host$level";
3611         my @host_seq = $level eq "easy" ?
3612             @reordered : 0..$last;  # reordered has CDROM up front
3613         my @urllist = map { $ccurllist->[$_] } @host_seq;
3614         for my $u (@CPAN::Defaultsites) {
3615             push @urllist, $u unless grep { $_ eq $u } @urllist;
3616         }
3617         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
3618         my $aslocal_tempfile = $aslocal . ".tmp" . $$;
3619         if (my $recommend = $self->_recommend_url_for($file)) {
3620             @urllist = grep { $_ ne $recommend } @urllist;
3621             unshift @urllist, $recommend;
3622         }
3623         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
3624         $ret = $self->$method(\@urllist,$file,$aslocal_tempfile,$stats);
3625         if ($ret) {
3626             CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG;
3627             if ($ret eq $aslocal_tempfile) {
3628                 # if we got it exactly as we asked for, only then we
3629                 # want to rename
3630                 rename $aslocal_tempfile, $aslocal
3631                     or $CPAN::Frontend->mydie("Error while trying to rename ".
3632                                               "'$ret' to '$aslocal': $!");
3633                 $ret = $aslocal;
3634             }
3635             $Themethod = $level;
3636             my $now = time;
3637             # utime $now, $now, $aslocal; # too bad, if we do that, we
3638                                           # might alter a local mirror
3639             $self->debug("level[$level]") if $CPAN::DEBUG;
3640             last LEVEL;
3641         } else {
3642             unlink $aslocal_tempfile;
3643             last if $CPAN::Signal; # need to cleanup
3644         }
3645     }
3646     if ($ret) {
3647         $stats->{filesize} = -s $ret;
3648     }
3649     $self->debug("before _add_to_statistics") if $CPAN::DEBUG;
3650     $self->_add_to_statistics($stats);
3651     $self->debug("after _add_to_statistics") if $CPAN::DEBUG;
3652     if ($ret) {
3653         unlink "$aslocal.bak$$";
3654         return $ret;
3655     }
3656     unless ($CPAN::Signal) {
3657         my(@mess);
3658         local $" = " ";
3659         if (@{$CPAN::Config->{urllist}}) {
3660             push @mess,
3661                 qq{Please check, if the URLs I found in your configuration file \(}.
3662                     join(", ", @{$CPAN::Config->{urllist}}).
3663                         qq{\) are valid.};
3664         } else {
3665             push @mess, qq{Your urllist is empty!};
3666         }
3667         push @mess, qq{The urllist can be edited.},
3668             qq{E.g. with 'o conf urllist push ftp://myurl/'};
3669         $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
3670         $CPAN::Frontend->mywarn("Could not fetch $file\n");
3671         $CPAN::Frontend->mysleep(2);
3672     }
3673     if ($maybe_restore) {
3674         rename "$aslocal.bak$$", $aslocal;
3675         $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
3676                                  $self->ls($aslocal));
3677         return $aslocal;
3678     }
3679     return;
3680 }
3681
3682 sub _set_attempt {
3683     my($self,$stats,$method,$url) = @_;
3684     push @{$stats->{attempts}}, {
3685                                  method => $method,
3686                                  start => _mytime,
3687                                  url => $url,
3688                                 };
3689 }
3690
3691 # package CPAN::FTP;
3692 sub hosteasy {
3693     my($self,$host_seq,$file,$aslocal,$stats) = @_;
3694     my($ro_url);
3695   HOSTEASY: for $ro_url (@$host_seq) {
3696         $self->_set_attempt($stats,"easy",$ro_url);
3697         my $url .= "$ro_url$file";
3698         $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
3699         if ($url =~ /^file:/) {
3700             my $l;
3701             if ($CPAN::META->has_inst('URI::URL')) {
3702                 my $u =  URI::URL->new($url);
3703                 $l = $u->path;
3704             } else { # works only on Unix, is poorly constructed, but
3705                 # hopefully better than nothing.
3706                 # RFC 1738 says fileurl BNF is
3707                 # fileurl = "file://" [ host | "localhost" ] "/" fpath
3708                 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
3709                 # the code
3710                 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
3711                 $l =~ s|^file:||;                   # assume they
3712                                                     # meant
3713                                                     # file://localhost
3714                 $l =~ s|^/||s
3715                     if ! -f $l && $l =~ m|^/\w:|;   # e.g. /P:
3716             }
3717             $self->debug("local file[$l]") if $CPAN::DEBUG;
3718             if ( -f $l && -r _) {
3719                 $ThesiteURL = $ro_url;
3720                 return $l;
3721             }
3722             if ($l =~ /(.+)\.gz$/) {
3723                 my $ungz = $1;
3724                 if ( -f $ungz && -r _) {
3725                     $ThesiteURL = $ro_url;
3726                     return $ungz;
3727                 }
3728             }
3729             # Maybe mirror has compressed it?
3730             if (-f "$l.gz") {
3731                 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
3732                 eval { CPAN::Tarzip->new("$l.gz")->gunzip($aslocal) };
3733                 if ( -f $aslocal) {
3734                     $ThesiteURL = $ro_url;
3735                     return $aslocal;
3736                 }
3737             }
3738         }
3739         $self->debug("it was not a file URL") if $CPAN::DEBUG;
3740         if ($CPAN::META->has_usable('LWP')) {
3741             $CPAN::Frontend->myprint("Fetching with LWP:
3742   $url
3743 ");
3744             unless ($Ua) {
3745                 CPAN::LWP::UserAgent->config;
3746                 eval { $Ua = CPAN::LWP::UserAgent->new; };
3747                 if ($@) {
3748                     $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
3749                 }
3750             }
3751             my $res = $Ua->mirror($url, $aslocal);
3752             if ($res->is_success) {
3753                 $ThesiteURL = $ro_url;
3754                 my $now = time;
3755                 utime $now, $now, $aslocal; # download time is more
3756                                             # important than upload
3757                                             # time
3758                 return $aslocal;
3759             } elsif ($url !~ /\.gz(?!\n)\Z/) {
3760                 my $gzurl = "$url.gz";
3761                 $CPAN::Frontend->myprint("Fetching with LWP:
3762   $gzurl
3763 ");
3764                 $res = $Ua->mirror($gzurl, "$aslocal.gz");
3765                 if ($res->is_success) {
3766                     if (eval {CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)}) {
3767                         $ThesiteURL = $ro_url;
3768                         return $aslocal;
3769                     }
3770                 }
3771             } else {
3772                 $CPAN::Frontend->myprint(sprintf(
3773                                                  "LWP failed with code[%s] message[%s]\n",
3774                                                  $res->code,
3775                                                  $res->message,
3776                                                 ));
3777                 # Alan Burlison informed me that in firewall environments
3778                 # Net::FTP can still succeed where LWP fails. So we do not
3779                 # skip Net::FTP anymore when LWP is available.
3780             }
3781         } else {
3782             $CPAN::Frontend->mywarn("  LWP not available\n");
3783         }
3784         return if $CPAN::Signal;
3785         if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3786             # that's the nice and easy way thanks to Graham
3787             $self->debug("recognized ftp") if $CPAN::DEBUG;
3788             my($host,$dir,$getfile) = ($1,$2,$3);
3789             if ($CPAN::META->has_usable('Net::FTP')) {
3790                 $dir =~ s|/+|/|g;
3791                 $CPAN::Frontend->myprint("Fetching with Net::FTP:
3792   $url
3793 ");
3794                 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
3795                              "aslocal[$aslocal]") if $CPAN::DEBUG;
3796                 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
3797                     $ThesiteURL = $ro_url;
3798                     return $aslocal;
3799                 }
3800                 if ($aslocal !~ /\.gz(?!\n)\Z/) {
3801                     my $gz = "$aslocal.gz";
3802                     $CPAN::Frontend->myprint("Fetching with Net::FTP
3803   $url.gz
3804 ");
3805                     if (CPAN::FTP->ftp_get($host,
3806                                            $dir,
3807                                            "$getfile.gz",
3808                                            $gz) &&
3809                         eval{CPAN::Tarzip->new($gz)->gunzip($aslocal)}
3810                        ){
3811                         $ThesiteURL = $ro_url;
3812                         return $aslocal;
3813                     }
3814                 }
3815                 # next HOSTEASY;
3816             } else {
3817                 CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG;
3818             }
3819         }
3820         if (
3821             UNIVERSAL::can($ro_url,"text")
3822             and
3823             $ro_url->{FROM} eq "USER"
3824            ){
3825             ##address #17973: default URLs should not try to override
3826             ##user-defined URLs just because LWP is not available
3827             my $ret = $self->hosthard([$ro_url],$file,$aslocal,$stats);
3828             return $ret if $ret;
3829         }
3830         return if $CPAN::Signal;
3831     }
3832 }
3833
3834 # package CPAN::FTP;
3835 sub hosthard {
3836   my($self,$host_seq,$file,$aslocal,$stats) = @_;
3837
3838   # Came back if Net::FTP couldn't establish connection (or
3839   # failed otherwise) Maybe they are behind a firewall, but they
3840   # gave us a socksified (or other) ftp program...
3841
3842   my($ro_url);
3843   my($devnull) = $CPAN::Config->{devnull} || "";
3844   # < /dev/null ";
3845   my($aslocal_dir) = File::Basename::dirname($aslocal);
3846   File::Path::mkpath($aslocal_dir);
3847   HOSTHARD: for $ro_url (@$host_seq) {
3848         $self->_set_attempt($stats,"hard",$ro_url);
3849         my $url = "$ro_url$file";
3850         my($proto,$host,$dir,$getfile);
3851
3852         # Courtesy Mark Conty mark_conty@cargill.com change from
3853         # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3854         # to
3855         if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
3856           # proto not yet used
3857           ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
3858         } else {
3859           next HOSTHARD; # who said, we could ftp anything except ftp?
3860         }
3861         next HOSTHARD if $proto eq "file"; # file URLs would have had
3862                                            # success above. Likely a bogus URL
3863
3864         $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
3865
3866         # Try the most capable first and leave ncftp* for last as it only
3867         # does FTP.
3868       DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
3869           my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
3870           next unless defined $funkyftp;
3871           next if $funkyftp =~ /^\s*$/;
3872
3873           my($asl_ungz, $asl_gz);
3874           ($asl_ungz = $aslocal) =~ s/\.gz//;
3875           $asl_gz = "$asl_ungz.gz";
3876
3877           my($src_switch) = "";
3878           my($chdir) = "";
3879           my($stdout_redir) = " > $asl_ungz";
3880           if ($f eq "lynx"){
3881             $src_switch = " -source";
3882           } elsif ($f eq "ncftp"){
3883             $src_switch = " -c";
3884           } elsif ($f eq "wget"){
3885             $src_switch = " -O $asl_ungz";
3886             $stdout_redir = "";
3887           } elsif ($f eq 'curl'){
3888             $src_switch = ' -L -f -s -S --netrc-optional';
3889           }
3890
3891           if ($f eq "ncftpget"){
3892             $chdir = "cd $aslocal_dir && ";
3893             $stdout_redir = "";
3894           }
3895           $CPAN::Frontend->myprint(
3896                                    qq[
3897 Trying with "$funkyftp$src_switch" to get
3898     $url
3899 ]);
3900           my($system) =
3901               "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
3902           $self->debug("system[$system]") if $CPAN::DEBUG;
3903           my($wstatus) = system($system);
3904           if ($f eq "lynx") {
3905               # lynx returns 0 when it fails somewhere
3906               if (-s $asl_ungz) {
3907                   my $content = do { local *FH;
3908                                      open FH, $asl_ungz or die;
3909                                      local $/;
3910                                      <FH> };
3911                   if ($content =~ /^<.*(<title>[45]|Error [45])/si) {
3912                       $CPAN::Frontend->mywarn(qq{
3913 No success, the file that lynx has has downloaded looks like an error message:
3914 $content
3915 });
3916                       $CPAN::Frontend->mysleep(1);
3917                       next DLPRG;
3918                   }
3919               } else {
3920                   $CPAN::Frontend->myprint(qq{
3921 No success, the file that lynx has has downloaded is an empty file.
3922 });
3923                   next DLPRG;
3924               }
3925           }
3926           if ($wstatus == 0) {
3927             if (-s $aslocal) {
3928               # Looks good
3929             } elsif ($asl_ungz ne $aslocal) {
3930               # test gzip integrity
3931               if (eval{CPAN::Tarzip->new($asl_ungz)->gtest}) {
3932                   # e.g. foo.tar is gzipped --> foo.tar.gz
3933                   rename $asl_ungz, $aslocal;
3934               } else {
3935                   eval{CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz)};
3936               }
3937             }
3938             $ThesiteURL = $ro_url;
3939             return $aslocal;
3940           } elsif ($url !~ /\.gz(?!\n)\Z/) {
3941             unlink $asl_ungz if
3942                 -f $asl_ungz && -s _ == 0;
3943             my $gz = "$aslocal.gz";
3944             my $gzurl = "$url.gz";
3945             $CPAN::Frontend->myprint(
3946                                      qq[
3947 Trying with "$funkyftp$src_switch" to get
3948   $url.gz
3949 ]);
3950             my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
3951             $self->debug("system[$system]") if $CPAN::DEBUG;
3952             my($wstatus);
3953             if (($wstatus = system($system)) == 0
3954                 &&
3955                 -s $asl_gz
3956                ) {
3957               # test gzip integrity
3958                 my $ct = eval{CPAN::Tarzip->new($asl_gz)};
3959                 if ($ct && $ct->gtest) {
3960                     $ct->gunzip($aslocal);
3961                 } else {
3962                     # somebody uncompressed file for us?
3963                     rename $asl_ungz, $aslocal;
3964                 }
3965                 $ThesiteURL = $ro_url;
3966                 return $aslocal;
3967             } else {
3968               unlink $asl_gz if -f $asl_gz;
3969             }
3970           } else {
3971             my $estatus = $wstatus >> 8;
3972             my $size = -f $aslocal ?
3973                 ", left\n$aslocal with size ".-s _ :
3974                     "\nWarning: expected file [$aslocal] doesn't exist";
3975             $CPAN::Frontend->myprint(qq{
3976 System call "$system"
3977 returned status $estatus (wstat $wstatus)$size
3978 });
3979           }
3980           return if $CPAN::Signal;
3981         } # transfer programs
3982     } # host
3983 }
3984
3985 # package CPAN::FTP;
3986 sub hosthardest {
3987     my($self,$host_seq,$file,$aslocal,$stats) = @_;
3988
3989     my($ro_url);
3990     my($aslocal_dir) = File::Basename::dirname($aslocal);
3991     File::Path::mkpath($aslocal_dir);
3992     my $ftpbin = $CPAN::Config->{ftp};
3993     unless ($ftpbin && length $ftpbin && MM->maybe_command($ftpbin)) {
3994         $CPAN::Frontend->myprint("No external ftp command available\n\n");
3995         return;
3996     }
3997     $CPAN::Frontend->mywarn(qq{
3998 As a last ressort we now switch to the external ftp command '$ftpbin'
3999 to get '$aslocal'.
4000
4001 Doing so often leads to problems that are hard to diagnose.
4002
4003 If you're victim of such problems, please consider unsetting the ftp
4004 config variable with
4005
4006     o conf ftp ""
4007     o conf commit
4008
4009 });
4010     $CPAN::Frontend->mysleep(2);
4011   HOSTHARDEST: for $ro_url (@$host_seq) {
4012         $self->_set_attempt($stats,"hardest",$ro_url);
4013         my $url = "$ro_url$file";
4014         $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
4015         unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
4016             next;
4017         }
4018         my($host,$dir,$getfile) = ($1,$2,$3);
4019         my $timestamp = 0;
4020         my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
4021            $ctime,$blksize,$blocks) = stat($aslocal);
4022         $timestamp = $mtime ||= 0;
4023         my($netrc) = CPAN::FTP::netrc->new;
4024         my($netrcfile) = $netrc->netrc;
4025         my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
4026         my $targetfile = File::Basename::basename($aslocal);
4027         my(@dialog);
4028         push(
4029              @dialog,
4030              "lcd $aslocal_dir",
4031              "cd /",
4032              map("cd $_", split /\//, $dir), # RFC 1738
4033              "bin",
4034              "get $getfile $targetfile",
4035              "quit"
4036             );
4037         if (! $netrcfile) {
4038             CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
4039         } elsif ($netrc->hasdefault || $netrc->contains($host)) {
4040             CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
4041                                 $netrc->hasdefault,
4042                                 $netrc->contains($host))) if $CPAN::DEBUG;
4043             if ($netrc->protected) {
4044                 my $dialog = join "", map { "    $_\n" } @dialog;
4045                 my $netrc_explain;
4046                 if ($netrc->contains($host)) {
4047                     $netrc_explain = "Relying that your .netrc entry for '$host' ".
4048                         "manages the login";
4049                 } else {
4050                     $netrc_explain = "Relying that your default .netrc entry ".
4051                         "manages the login";
4052                 }
4053                 $CPAN::Frontend->myprint(qq{
4054   Trying with external ftp to get
4055     $url
4056   $netrc_explain
4057   Going to send the dialog
4058 $dialog
4059 }
4060                      );
4061                 $self->talk_ftp("$ftpbin$verbose $host",
4062                                 @dialog);
4063                 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4064                  $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
4065                 $mtime ||= 0;
4066                 if ($mtime > $timestamp) {
4067                     $CPAN::Frontend->myprint("GOT $aslocal\n");
4068                     $ThesiteURL = $ro_url;
4069                     return $aslocal;
4070                 } else {
4071                     $CPAN::Frontend->myprint("Hmm... Still failed!\n");
4072                 }
4073                 return if $CPAN::Signal;
4074             } else {
4075                 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
4076                                         qq{correctly protected.\n});
4077             }
4078         } else {
4079             $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
4080   nor does it have a default entry\n");
4081         }
4082
4083         # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
4084         # then and login manually to host, using e-mail as
4085         # password.
4086         $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
4087         unshift(
4088                 @dialog,
4089                 "open $host",
4090                 "user anonymous $Config::Config{'cf_email'}"
4091                );
4092         my $dialog = join "", map { "    $_\n" } @dialog;
4093         $CPAN::Frontend->myprint(qq{
4094   Trying with external ftp to get
4095     $url
4096   Going to send the dialog
4097 $dialog
4098 }
4099                      );
4100         $self->talk_ftp("$ftpbin$verbose -n", @dialog);
4101         ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4102          $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
4103         $mtime ||= 0;
4104         if ($mtime > $timestamp) {
4105             $CPAN::Frontend->myprint("GOT $aslocal\n");
4106             $ThesiteURL = $ro_url;
4107             return $aslocal;
4108         } else {
4109             $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
4110         }
4111         return if $CPAN::Signal;
4112         $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
4113         $CPAN::Frontend->mysleep(2);
4114     } # host
4115 }
4116
4117 # package CPAN::FTP;
4118 sub talk_ftp {
4119     my($self,$command,@dialog) = @_;
4120     my $fh = FileHandle->new;
4121     $fh->open("|$command") or die "Couldn't open ftp: $!";
4122     foreach (@dialog) { $fh->print("$_\n") }
4123     $fh->close;         # Wait for process to complete
4124     my $wstatus = $?;
4125     my $estatus = $wstatus >> 8;
4126     $CPAN::Frontend->myprint(qq{
4127 Subprocess "|$command"
4128   returned status $estatus (wstat $wstatus)
4129 }) if $wstatus;
4130 }
4131
4132 # find2perl needs modularization, too, all the following is stolen
4133 # from there
4134 # CPAN::FTP::ls
4135 sub ls {
4136     my($self,$name) = @_;
4137     my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
4138      $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
4139
4140     my($perms,%user,%group);
4141     my $pname = $name;
4142
4143     if ($blocks) {
4144         $blocks = int(($blocks + 1) / 2);
4145     }
4146     else {
4147         $blocks = int(($sizemm + 1023) / 1024);
4148     }
4149
4150     if    (-f _) { $perms = '-'; }
4151     elsif (-d _) { $perms = 'd'; }
4152     elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
4153     elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
4154     elsif (-p _) { $perms = 'p'; }
4155     elsif (-S _) { $perms = 's'; }
4156     else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
4157
4158     my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
4159     my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
4160     my $tmpmode = $mode;
4161     my $tmp = $rwx[$tmpmode & 7];
4162     $tmpmode >>= 3;
4163     $tmp = $rwx[$tmpmode & 7] . $tmp;
4164     $tmpmode >>= 3;
4165     $tmp = $rwx[$tmpmode & 7] . $tmp;
4166     substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
4167     substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
4168     substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
4169     $perms .= $tmp;
4170
4171     my $user = $user{$uid} || $uid;   # too lazy to implement lookup
4172     my $group = $group{$gid} || $gid;
4173
4174     my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
4175     my($timeyear);
4176     my($moname) = $moname[$mon];
4177     if (-M _ > 365.25 / 2) {
4178         $timeyear = $year + 1900;
4179     }
4180     else {
4181         $timeyear = sprintf("%02d:%02d", $hour, $min);
4182     }
4183
4184     sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
4185             $ino,
4186                  $blocks,
4187                       $perms,
4188                             $nlink,
4189                                 $user,
4190                                      $group,
4191                                           $sizemm,
4192                                               $moname,
4193                                                  $mday,
4194                                                      $timeyear,
4195                                                          $pname;
4196 }
4197
4198 package CPAN::FTP::netrc;
4199 use strict;
4200
4201 # package CPAN::FTP::netrc;
4202 sub new {
4203     my($class) = @_;
4204     my $home = CPAN::HandleConfig::home;
4205     my $file = File::Spec->catfile($home,".netrc");
4206
4207     my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4208        $atime,$mtime,$ctime,$blksize,$blocks)
4209         = stat($file);
4210     $mode ||= 0;
4211     my $protected = 0;
4212
4213     my($fh,@machines,$hasdefault);
4214     $hasdefault = 0;
4215     $fh = FileHandle->new or die "Could not create a filehandle";
4216
4217     if($fh->open($file)){
4218         $protected = ($mode & 077) == 0;
4219         local($/) = "";
4220       NETRC: while (<$fh>) {
4221             my(@tokens) = split " ", $_;
4222           TOKEN: while (@tokens) {
4223                 my($t) = shift @tokens;
4224                 if ($t eq "default"){
4225                     $hasdefault++;
4226                     last NETRC;
4227                 }
4228                 last TOKEN if $t eq "macdef";
4229                 if ($t eq "machine") {
4230                     push @machines, shift @tokens;
4231                 }
4232             }
4233         }
4234     } else {
4235         $file = $hasdefault = $protected = "";
4236     }
4237
4238     bless {
4239            'mach' => [@machines],
4240            'netrc' => $file,
4241            'hasdefault' => $hasdefault,
4242            'protected' => $protected,
4243           }, $class;
4244 }
4245
4246 # CPAN::FTP::netrc::hasdefault;
4247 sub hasdefault { shift->{'hasdefault'} }
4248 sub netrc      { shift->{'netrc'}      }
4249 sub protected  { shift->{'protected'}  }
4250 sub contains {
4251     my($self,$mach) = @_;
4252     for ( @{$self->{'mach'}} ) {
4253         return 1 if $_ eq $mach;
4254     }
4255     return 0;
4256 }
4257
4258 package CPAN::Complete;
4259 use strict;
4260
4261 sub gnu_cpl {
4262     my($text, $line, $start, $end) = @_;
4263     my(@perlret) = cpl($text, $line, $start);
4264     # find longest common match. Can anybody show me how to peruse
4265     # T::R::Gnu to have this done automatically? Seems expensive.
4266     return () unless @perlret;
4267     my($newtext) = $text;
4268     for (my $i = length($text)+1;;$i++) {
4269         last unless length($perlret[0]) && length($perlret[0]) >= $i;
4270         my $try = substr($perlret[0],0,$i);
4271         my @tries = grep {substr($_,0,$i) eq $try} @perlret;
4272         # warn "try[$try]tries[@tries]";
4273         if (@tries == @perlret) {
4274             $newtext = $try;
4275         } else {
4276             last;
4277         }
4278     }
4279     ($newtext,@perlret);
4280 }
4281
4282 #-> sub CPAN::Complete::cpl ;
4283 sub cpl {
4284     my($word,$line,$pos) = @_;
4285     $word ||= "";
4286     $line ||= "";
4287     $pos ||= 0;
4288     CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4289     $line =~ s/^\s*//;
4290     if ($line =~ s/^((?:notest|f?force)\s*)//) {
4291         $pos -= length($1);
4292     }
4293     my @return;
4294     if ($pos == 0) {
4295         @return = grep /^$word/, @CPAN::Complete::COMMANDS;
4296     } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
4297         @return = ();
4298     } elsif ($line =~ /^(a|ls)\s/) {
4299         @return = cplx('CPAN::Author',uc($word));
4300     } elsif ($line =~ /^b\s/) {
4301         CPAN::Shell->local_bundles;
4302         @return = cplx('CPAN::Bundle',$word);
4303     } elsif ($line =~ /^d\s/) {
4304         @return = cplx('CPAN::Distribution',$word);
4305     } elsif ($line =~ m/^(
4306                           [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
4307                          )\s/x ) {
4308         if ($word =~ /^Bundle::/) {
4309             CPAN::Shell->local_bundles;
4310         }
4311         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
4312     } elsif ($line =~ /^i\s/) {
4313         @return = cpl_any($word);
4314     } elsif ($line =~ /^reload\s/) {
4315         @return = cpl_reload($word,$line,$pos);
4316     } elsif ($line =~ /^o\s/) {
4317         @return = cpl_option($word,$line,$pos);
4318     } elsif ($line =~ m/^\S+\s/ ) {
4319         # fallback for future commands and what we have forgotten above
4320         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
4321     } else {
4322         @return = ();
4323     }
4324     return @return;
4325 }
4326
4327 #-> sub CPAN::Complete::cplx ;
4328 sub cplx {
4329     my($class, $word) = @_;
4330     if (CPAN::_sqlite_running) {
4331         $CPAN::SQLite->search($class, "^\Q$word\E");
4332     }
4333     sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
4334 }
4335
4336 #-> sub CPAN::Complete::cpl_any ;
4337 sub cpl_any {
4338     my($word) = shift;
4339     return (
4340             cplx('CPAN::Author',$word),
4341             cplx('CPAN::Bundle',$word),
4342             cplx('CPAN::Distribution',$word),
4343             cplx('CPAN::Module',$word),
4344            );
4345 }
4346
4347 #-> sub CPAN::Complete::cpl_reload ;
4348 sub cpl_reload {
4349     my($word,$line,$pos) = @_;
4350     $word ||= "";
4351     my(@words) = split " ", $line;
4352     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4353     my(@ok) = qw(cpan index);
4354     return @ok if @words == 1;
4355     return grep /^\Q$word\E/, @ok if @words == 2 && $word;
4356 }
4357
4358 #-> sub CPAN::Complete::cpl_option ;
4359 sub cpl_option {
4360     my($word,$line,$pos) = @_;
4361     $word ||= "";
4362     my(@words) = split " ", $line;
4363     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4364     my(@ok) = qw(conf debug);
4365     return @ok if @words == 1;
4366     return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
4367     if (0) {
4368     } elsif ($words[1] eq 'index') {
4369         return ();
4370     } elsif ($words[1] eq 'conf') {
4371         return CPAN::HandleConfig::cpl(@_);
4372     } elsif ($words[1] eq 'debug') {
4373         return sort grep /^\Q$word\E/i,
4374             sort keys %CPAN::DEBUG, 'all';
4375     }
4376 }
4377
4378 package CPAN::Index;
4379 use strict;
4380
4381 #-> sub CPAN::Index::force_reload ;
4382 sub force_reload {
4383     my($class) = @_;
4384     $CPAN::Index::LAST_TIME = 0;
4385     $class->reload(1);
4386 }
4387
4388 #-> sub CPAN::Index::reload ;
4389 sub reload {
4390     my($self,$force) = @_;
4391     my $time = time;
4392
4393     # XXX check if a newer one is available. (We currently read it
4394     # from time to time)
4395     for ($CPAN::Config->{index_expire}) {
4396         $_ = 0.001 unless $_ && $_ > 0.001;
4397     }
4398     unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
4399         # debug here when CPAN doesn't seem to read the Metadata
4400         require Carp;
4401         Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
4402     }
4403     unless ($CPAN::META->{PROTOCOL}) {
4404         $self->read_metadata_cache;
4405         $CPAN::META->{PROTOCOL} ||= "1.0";
4406     }
4407     if ( $CPAN::META->{PROTOCOL} < PROTOCOL  ) {
4408         # warn "Setting last_time to 0";
4409         $LAST_TIME = 0; # No warning necessary
4410     }
4411     if ($LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
4412         and ! $force){
4413         # called too often
4414         # CPAN->debug("LAST_TIME[$LAST_TIME]index_expire[$CPAN::Config->{index_expire}]time[$time]");
4415     } elsif (0) {
4416         # IFF we are developing, it helps to wipe out the memory
4417         # between reloads, otherwise it is not what a user expects.
4418         undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
4419         $CPAN::META = CPAN->new;
4420     } else {
4421         my($debug,$t2);
4422         local $LAST_TIME = $time;
4423         local $CPAN::META->{PROTOCOL} = PROTOCOL;
4424
4425         my $needshort = $^O eq "dos";
4426
4427         $self->rd_authindex($self
4428                           ->reload_x(
4429                                      "authors/01mailrc.txt.gz",
4430                                      $needshort ?
4431                                      File::Spec->catfile('authors', '01mailrc.gz') :
4432                                      File::Spec->catfile('authors', '01mailrc.txt.gz'),
4433                                      $force));
4434         $t2 = time;
4435         $debug = "timing reading 01[".($t2 - $time)."]";
4436         $time = $t2;
4437         return if $CPAN::Signal; # this is sometimes lengthy
4438         $self->rd_modpacks($self
4439                          ->reload_x(
4440                                     "modules/02packages.details.txt.gz",
4441                                     $needshort ?
4442                                     File::Spec->catfile('modules', '02packag.gz') :
4443                                     File::Spec->catfile('modules', '02packages.details.txt.gz'),
4444                                     $force));
4445         $t2 = time;
4446         $debug .= "02[".($t2 - $time)."]";
4447         $time = $t2;
4448         return if $CPAN::Signal; # this is sometimes lengthy
4449         $self->rd_modlist($self
4450                         ->reload_x(
4451                                    "modules/03modlist.data.gz",
4452                                    $needshort ?
4453                                    File::Spec->catfile('modules', '03mlist.gz') :
4454                                    File::Spec->catfile('modules', '03modlist.data.gz'),
4455                                    $force));
4456         $self->write_metadata_cache;
4457         $t2 = time;
4458         $debug .= "03[".($t2 - $time)."]";
4459         $time = $t2;
4460         CPAN->debug($debug) if $CPAN::DEBUG;
4461     }
4462     if ($CPAN::Config->{build_dir_reuse}) {
4463         $self->reanimate_build_dir;
4464     }
4465     if (CPAN::_sqlite_running) {
4466         $CPAN::SQLite->reload(time => $time, force => $force)
4467             if not $LAST_TIME;
4468     }
4469     $LAST_TIME = $time;
4470     $CPAN::META->{PROTOCOL} = PROTOCOL;
4471 }
4472
4473 #-> sub CPAN::Index::reanimate_build_dir ;
4474 sub reanimate_build_dir {
4475     my($self) = @_;
4476     unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module}||"YAML")) {
4477         return;
4478     }
4479     return if $HAVE_REANIMATED++;
4480     my $d = $CPAN::Config->{build_dir};
4481     my $dh = DirHandle->new;
4482     opendir $dh, $d or return; # does not exist
4483     my $dirent;
4484     my $i = 0;
4485     my $painted = 0;
4486     my $restored = 0;
4487     $CPAN::Frontend->myprint("Going to read $CPAN::Config->{build_dir}/\n");
4488     my @candidates = map { $_->[0] }
4489         sort { $b->[1] <=> $a->[1] }
4490             map { [ $_, -M File::Spec->catfile($d,$_) ] }
4491                 grep {/\.yml$/} readdir $dh;
4492   DISTRO: for $dirent (@candidates) {
4493         my $y = eval {CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))};
4494         die $@ if $@;
4495         my $c = $y->[0];
4496         if ($c && CPAN->_perl_fingerprint($c->{perl})) {
4497             my $key = $c->{distribution}{ID};
4498             for my $k (keys %{$c->{distribution}}) {
4499                 if ($c->{distribution}{$k}
4500                     && ref $c->{distribution}{$k}
4501                     && UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) {
4502                     $c->{distribution}{$k}{COMMANDID} = $i - @candidates;
4503                 }
4504             }
4505
4506             #we tried to restore only if element already
4507             #exists; but then we do not work with metadata
4508             #turned off.
4509             my $do
4510                 = $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key}
4511                     = $c->{distribution};
4512             delete $do->{badtestcnt};
4513             # $DB::single = 1;
4514             if ($do->{make_test}
4515                 && $do->{build_dir}
4516                 && !$do->{make_test}->failed
4517                 && (
4518                     !$do->{install}
4519                     ||
4520                     $do->{install}->failed
4521                    )
4522                ) {
4523                 $CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME});
4524             }
4525             $restored++;
4526         }
4527         $i++;
4528         while (($painted/76) < ($i/@candidates)) {
4529             $CPAN::Frontend->myprint(".");
4530             $painted++;
4531         }
4532     }
4533     $CPAN::Frontend->myprint(sprintf(
4534                                      "DONE\nFound %s old builds, restored the state of %s\n",
4535                                      @candidates ? sprintf("%d",scalar @candidates) : "no",
4536                                      $restored || "none",
4537                                     ));
4538 }
4539
4540
4541 #-> sub CPAN::Index::reload_x ;
4542 sub reload_x {
4543     my($cl,$wanted,$localname,$force) = @_;
4544     $force |= 2; # means we're dealing with an index here
4545     CPAN::HandleConfig->load; # we should guarantee loading wherever
4546                               # we rely on Config XXX
4547     $localname ||= $wanted;
4548     my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
4549                                          $localname);
4550     if (
4551         -f $abs_wanted &&
4552         -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
4553         !($force & 1)
4554        ) {
4555         my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
4556         $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
4557                    qq{day$s. I\'ll use that.});
4558         return $abs_wanted;
4559     } else {
4560         $force |= 1; # means we're quite serious about it.
4561     }
4562     return CPAN::FTP->localize($wanted,$abs_wanted,$force);
4563 }
4564
4565 #-> sub CPAN::Index::rd_authindex ;
4566 sub rd_authindex {
4567     my($cl, $index_target) = @_;
4568     return unless defined $index_target;
4569     return if CPAN::_sqlite_running;
4570     my @lines;
4571     $CPAN::Frontend->myprint("Going to read $index_target\n");
4572     local(*FH);
4573     tie *FH, 'CPAN::Tarzip', $index_target;
4574     local($/) = "\n";
4575     local($_);
4576     push @lines, split /\012/ while <FH>;
4577     my $i = 0;
4578     my $painted = 0;
4579     foreach (@lines) {
4580         my($userid,$fullname,$email) =
4581             m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/;
4582         $fullname ||= $email;
4583         if ($userid && $fullname && $email){
4584             my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
4585             $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
4586         } else {
4587             CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG;
4588         }
4589         $i++;
4590         while (($painted/76) < ($i/@lines)) {
4591             $CPAN::Frontend->myprint(".");
4592             $painted++;
4593         }
4594         return if $CPAN::Signal;
4595     }
4596     $CPAN::Frontend->myprint("DONE\n");
4597 }
4598
4599 sub userid {
4600   my($self,$dist) = @_;
4601   $dist = $self->{'id'} unless defined $dist;
4602   my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
4603   $ret;
4604 }
4605
4606 #-> sub CPAN::Index::rd_modpacks ;
4607 sub rd_modpacks {
4608     my($self, $index_target) = @_;
4609     return unless defined $index_target;
4610     return if CPAN::_sqlite_running;
4611     $CPAN::Frontend->myprint("Going to read $index_target\n");
4612     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
4613     local $_;
4614     CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
4615     my $slurp = "";
4616     my $chunk;
4617     while (my $bytes = $fh->READ(\$chunk,8192)) {
4618         $slurp.=$chunk;
4619     }
4620     my @lines = split /\012/, $slurp;
4621     CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
4622     undef $fh;
4623     # read header
4624     my($line_count,$last_updated);
4625     while (@lines) {
4626         my $shift = shift(@lines);
4627         last if $shift =~ /^\s*$/;
4628         $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
4629         $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
4630     }
4631     CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
4632     if (not defined $line_count) {
4633
4634         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
4635 Please check the validity of the index file by comparing it to more
4636 than one CPAN mirror. I'll continue but problems seem likely to
4637 happen.\a
4638 });
4639
4640         $CPAN::Frontend->mysleep(5);
4641     } elsif ($line_count != scalar @lines) {
4642
4643         $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
4644 contains a Line-Count header of %d but I see %d lines there. Please
4645 check the validity of the index file by comparing it to more than one
4646 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
4647 $index_target, $line_count, scalar(@lines));
4648
4649     }
4650     if (not defined $last_updated) {
4651
4652         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
4653 Please check the validity of the index file by comparing it to more
4654 than one CPAN mirror. I'll continue but problems seem likely to
4655 happen.\a
4656 });
4657
4658         $CPAN::Frontend->mysleep(5);
4659     } else {
4660
4661         $CPAN::Frontend
4662             ->myprint(sprintf qq{  Database was generated on %s\n},
4663                       $last_updated);
4664         $DATE_OF_02 = $last_updated;
4665
4666         my $age = time;
4667         if ($CPAN::META->has_inst('HTTP::Date')) {
4668             require HTTP::Date;
4669             $age -= HTTP::Date::str2time($last_updated);
4670         } else {
4671             $CPAN::Frontend->mywarn("  HTTP::Date not available\n");
4672             require Time::Local;
4673             my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
4674             $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
4675             $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
4676         }
4677         $age /= 3600*24;
4678         if ($age > 30) {
4679
4680             $CPAN::Frontend
4681                 ->mywarn(sprintf
4682                          qq{Warning: This index file is %d days old.
4683   Please check the host you chose as your CPAN mirror for staleness.
4684   I'll continue but problems seem likely to happen.\a\n},
4685                          $age);
4686
4687         } elsif ($age < -1) {
4688
4689             $CPAN::Frontend
4690                 ->mywarn(sprintf
4691                          qq{Warning: Your system date is %d days behind this index file!
4692   System time:          %s
4693   Timestamp index file: %s
4694   Please fix your system time, problems with the make command expected.\n},
4695                          -$age,
4696                          scalar gmtime,
4697                          $DATE_OF_02,
4698                         );
4699
4700         }
4701     }
4702
4703
4704     # A necessity since we have metadata_cache: delete what isn't
4705     # there anymore
4706     my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
4707     CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
4708     my(%exists);
4709     my $i = 0;
4710     my $painted = 0;
4711     foreach (@lines) {
4712         # before 1.56 we split into 3 and discarded the rest. From
4713         # 1.57 we assign remaining text to $comment thus allowing to
4714         # influence isa_perl
4715         my($mod,$version,$dist,$comment) = split " ", $_, 4;
4716         my($bundle,$id,$userid);
4717
4718         if ($mod eq 'CPAN' &&
4719             ! (
4720                CPAN::Queue->exists('Bundle::CPAN') ||
4721                CPAN::Queue->exists('CPAN')
4722               )
4723            ) {
4724             local($^W)= 0;
4725             if ($version > $CPAN::VERSION){
4726                 $CPAN::Frontend->mywarn(qq{
4727   New CPAN.pm version (v$version) available.
4728   [Currently running version is v$CPAN::VERSION]
4729   You might want to try
4730     install CPAN
4731     reload cpan
4732   to both upgrade CPAN.pm and run the new version without leaving
4733   the current session.
4734
4735 }); #});
4736                 $CPAN::Frontend->mysleep(2);
4737                 $CPAN::Frontend->myprint(qq{\n});
4738             }
4739             last if $CPAN::Signal;
4740         } elsif ($mod =~ /^Bundle::(.*)/) {
4741             $bundle = $1;
4742         }
4743
4744         if ($bundle){
4745             $id =  $CPAN::META->instance('CPAN::Bundle',$mod);
4746             # Let's make it a module too, because bundles have so much
4747             # in common with modules.
4748
4749             # Changed in 1.57_63: seems like memory bloat now without
4750             # any value, so commented out
4751
4752             # $CPAN::META->instance('CPAN::Module',$mod);
4753
4754         } else {
4755
4756             # instantiate a module object
4757             $id = $CPAN::META->instance('CPAN::Module',$mod);
4758
4759         }
4760
4761         # Although CPAN prohibits same name with different version the
4762         # indexer may have changed the version for the same distro
4763         # since the last time ("Force Reindexing" feature)
4764         if ($id->cpan_file ne $dist
4765             ||
4766             $id->cpan_version ne $version
4767            ){
4768             $userid = $id->userid || $self->userid($dist);
4769             $id->set(
4770                      'CPAN_USERID' => $userid,
4771                      'CPAN_VERSION' => $version,
4772                      'CPAN_FILE' => $dist,
4773                     );
4774         }
4775
4776         # instantiate a distribution object
4777         if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
4778           # we do not need CONTAINSMODS unless we do something with
4779           # this dist, so we better produce it on demand.
4780
4781           ## my $obj = $CPAN::META->instance(
4782           ##                              'CPAN::Distribution' => $dist
4783           ##                             );
4784           ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
4785         } else {
4786           $CPAN::META->instance(
4787                                 'CPAN::Distribution' => $dist
4788                                )->set(
4789                                       'CPAN_USERID' => $userid,
4790                                       'CPAN_COMMENT' => $comment,
4791                                      );
4792         }
4793         if ($secondtime) {
4794             for my $name ($mod,$dist) {
4795                 # $self->debug("exists name[$name]") if $CPAN::DEBUG;
4796                 $exists{$name} = undef;
4797             }
4798         }
4799         $i++;
4800         while (($painted/76) < ($i/@lines)) {
4801             $CPAN::Frontend->myprint(".");
4802             $painted++;
4803         }
4804         return if $CPAN::Signal;
4805     }
4806     $CPAN::Frontend->myprint("DONE\n");
4807     if ($secondtime) {
4808         for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
4809             for my $o ($CPAN::META->all_objects($class)) {
4810                 next if exists $exists{$o->{ID}};
4811                 $CPAN::META->delete($class,$o->{ID});
4812                 # CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
4813                 #     if $CPAN::DEBUG;
4814             }
4815         }
4816     }
4817 }
4818
4819 #-> sub CPAN::Index::rd_modlist ;
4820 sub rd_modlist {
4821     my($cl,$index_target) = @_;
4822     return unless defined $index_target;
4823     return if CPAN::_sqlite_running;
4824     $CPAN::Frontend->myprint("Going to read $index_target\n");
4825     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
4826     local $_;
4827     my $slurp = "";
4828     my $chunk;
4829     while (my $bytes = $fh->READ(\$chunk,8192)) {
4830         $slurp.=$chunk;
4831     }
4832     my @eval2 = split /\012/, $slurp;
4833
4834     while (@eval2) {
4835         my $shift = shift(@eval2);
4836         if ($shift =~ /^Date:\s+(.*)/){
4837             if ($DATE_OF_03 eq $1){
4838                 $CPAN::Frontend->myprint("Unchanged.\n");
4839                 return;
4840             }
4841             ($DATE_OF_03) = $1;
4842         }
4843         last if $shift =~ /^\s*$/;
4844     }
4845     push @eval2, q{CPAN::Modulelist->data;};
4846     local($^W) = 0;
4847     my($comp) = Safe->new("CPAN::Safe1");
4848     my($eval2) = join("\n", @eval2);
4849     CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG;
4850     my $ret = $comp->reval($eval2);
4851     Carp::confess($@) if $@;
4852     return if $CPAN::Signal;
4853     my $i = 0;
4854     my $until = keys(%$ret);
4855     my $painted = 0;
4856     CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
4857     for (keys %$ret) {
4858         my $obj = $CPAN::META->instance("CPAN::Module",$_);
4859         delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
4860         $obj->set(%{$ret->{$_}});
4861         $i++;
4862         while (($painted/76) < ($i/$until)) {
4863             $CPAN::Frontend->myprint(".");
4864             $painted++;
4865         }
4866         return if $CPAN::Signal;
4867     }
4868     $CPAN::Frontend->myprint("DONE\n");
4869 }
4870
4871 #-> sub CPAN::Index::write_metadata_cache ;
4872 sub write_metadata_cache {
4873     my($self) = @_;
4874     return unless $CPAN::Config->{'cache_metadata'};
4875     return if CPAN::_sqlite_running;
4876     return unless $CPAN::META->has_usable("Storable");
4877     my $cache;
4878     foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
4879                       CPAN::Distribution)) {
4880         $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
4881     }
4882     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
4883     $cache->{last_time} = $LAST_TIME;
4884     $cache->{DATE_OF_02} = $DATE_OF_02;
4885     $cache->{PROTOCOL} = PROTOCOL;
4886     $CPAN::Frontend->myprint("Going to write $metadata_file\n");
4887     eval { Storable::nstore($cache, $metadata_file) };
4888     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
4889 }
4890
4891 #-> sub CPAN::Index::read_metadata_cache ;
4892 sub read_metadata_cache {
4893     my($self) = @_;
4894     return unless $CPAN::Config->{'cache_metadata'};
4895     return if CPAN::_sqlite_running;
4896     return unless $CPAN::META->has_usable("Storable");
4897     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
4898     return unless -r $metadata_file and -f $metadata_file;
4899     $CPAN::Frontend->myprint("Going to read $metadata_file\n");
4900     my $cache;
4901     eval { $cache = Storable::retrieve($metadata_file) };
4902     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
4903     if (!$cache || !UNIVERSAL::isa($cache, 'HASH')){
4904         $LAST_TIME = 0;
4905         return;
4906     }
4907     if (exists $cache->{PROTOCOL}) {
4908         if (PROTOCOL > $cache->{PROTOCOL}) {
4909             $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
4910                                             "with protocol v%s, requiring v%s\n",
4911                                             $cache->{PROTOCOL},
4912                                             PROTOCOL)
4913                                    );
4914             return;
4915         }
4916     } else {
4917         $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
4918                                 "with protocol v1.0\n");
4919         return;
4920     }
4921     my $clcnt = 0;
4922     my $idcnt = 0;
4923     while(my($class,$v) = each %$cache) {
4924         next unless $class =~ /^CPAN::/;
4925         $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
4926         while (my($id,$ro) = each %$v) {
4927             $CPAN::META->{readwrite}{$class}{$id} ||=
4928                 $class->new(ID=>$id, RO=>$ro);
4929             $idcnt++;
4930         }
4931         $clcnt++;
4932     }
4933     unless ($clcnt) { # sanity check
4934         $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
4935         return;
4936     }
4937     if ($idcnt < 1000) {
4938         $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
4939                                  "in $metadata_file\n");
4940         return;
4941     }
4942     $CPAN::META->{PROTOCOL} ||=
4943         $cache->{PROTOCOL}; # reading does not up or downgrade, but it
4944                             # does initialize to some protocol
4945     $LAST_TIME = $cache->{last_time};
4946     $DATE_OF_02 = $cache->{DATE_OF_02};
4947     $CPAN::Frontend->myprint("  Database was generated on $DATE_OF_02\n")
4948         if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
4949     return;
4950 }
4951
4952 package CPAN::InfoObj;
4953 use strict;
4954
4955 sub ro {
4956     my $self = shift;
4957     exists $self->{RO} and return $self->{RO};
4958 }
4959
4960 #-> sub CPAN::InfoObj::cpan_userid
4961 sub cpan_userid {
4962     my $self = shift;
4963     my $ro = $self->ro;
4964     if ($ro) {
4965         return $ro->{CPAN_USERID} || "N/A";
4966     } else {
4967         $self->debug("ID[$self->{ID}]");
4968         # N/A for bundles found locally
4969         return "N/A";
4970     }
4971 }
4972
4973 sub id { shift->{ID}; }
4974
4975 #-> sub CPAN::InfoObj::new ;
4976 sub new {
4977     my $this = bless {}, shift;
4978     %$this = @_;
4979     $this
4980 }
4981
4982 # The set method may only be used by code that reads index data or
4983 # otherwise "objective" data from the outside world. All session
4984 # related material may do anything else with instance variables but
4985 # must not touch the hash under the RO attribute. The reason is that
4986 # the RO hash gets written to Metadata file and is thus persistent.
4987
4988 #-> sub CPAN::InfoObj::safe_chdir ;
4989 sub safe_chdir {
4990   my($self,$todir) = @_;
4991   # we die if we cannot chdir and we are debuggable
4992   Carp::confess("safe_chdir called without todir argument")
4993         unless defined $todir and length $todir;
4994   if (chdir $todir) {
4995     $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
4996         if $CPAN::DEBUG;
4997   } else {
4998     if (-e $todir) {
4999         unless (-x $todir) {
5000             unless (chmod 0755, $todir) {
5001                 my $cwd = CPAN::anycwd();
5002                 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
5003                                         "permission to change the permission; cannot ".
5004                                         "chdir to '$todir'\n");
5005                 $CPAN::Frontend->mysleep(5);
5006                 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
5007                                        qq{to todir[$todir]: $!});
5008             }
5009         }
5010     } else {
5011         $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n");
5012     }
5013     if (chdir $todir) {
5014       $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
5015           if $CPAN::DEBUG;
5016     } else {
5017       my $cwd = CPAN::anycwd();
5018       $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
5019                              qq{to todir[$todir] (a chmod has been issued): $!});
5020     }
5021   }
5022 }
5023
5024 #-> sub CPAN::InfoObj::set ;
5025 sub set {
5026     my($self,%att) = @_;
5027     my $class = ref $self;
5028
5029     # This must be ||=, not ||, because only if we write an empty
5030     # reference, only then the set method will write into the readonly
5031     # area. But for Distributions that spring into existence, maybe
5032     # because of a typo, we do not like it that they are written into
5033     # the readonly area and made permanent (at least for a while) and
5034     # that is why we do not "allow" other places to call ->set.
5035     unless ($self->id) {
5036         CPAN->debug("Bug? Empty ID, rejecting");
5037         return;
5038     }
5039     my $ro = $self->{RO} =
5040         $CPAN::META->{readonly}{$class}{$self->id} ||= {};
5041
5042     while (my($k,$v) = each %att) {
5043         $ro->{$k} = $v;
5044     }
5045 }
5046
5047 #-> sub CPAN::InfoObj::as_glimpse ;
5048 sub as_glimpse {
5049     my($self) = @_;
5050     my(@m);
5051     my $class = ref($self);
5052     $class =~ s/^CPAN:://;
5053     my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID};
5054     push @m, sprintf "%-15s %s\n", $class, $id;
5055     join "", @m;
5056 }
5057
5058 #-> sub CPAN::InfoObj::as_string ;
5059 sub as_string {
5060     my($self) = @_;
5061     my(@m);
5062     my $class = ref($self);
5063     $class =~ s/^CPAN:://;
5064     push @m, $class, " id = $self->{ID}\n";
5065     my $ro;
5066     unless ($ro = $self->ro) {
5067         if (substr($self->{ID},-1,1) eq ".") { # directory
5068             $ro = +{};
5069         } else {
5070             $CPAN::Frontend->mydie("Unknown object $self->{ID}");
5071         }
5072     }
5073     for (sort keys %$ro) {
5074         # next if m/^(ID|RO)$/;
5075         my $extra = "";
5076         if ($_ eq "CPAN_USERID") {
5077             $extra .= " (";
5078             $extra .= $self->fullname;
5079             my $email; # old perls!
5080             if ($email = $CPAN::META->instance("CPAN::Author",
5081                                                $self->cpan_userid
5082                                               )->email) {
5083                 $extra .= " <$email>";
5084             } else {
5085                 $extra .= " <no email>";
5086             }
5087             $extra .= ")";
5088         } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
5089             push @m, sprintf "    %-12s %s\n", $_, $self->fullname;
5090             next;
5091         }
5092         next unless defined $ro->{$_};
5093         push @m, sprintf "    %-12s %s%s\n", $_, $ro->{$_}, $extra;
5094     }
5095   KEY: for (sort keys %$self) {
5096         next if m/^(ID|RO)$/;
5097         unless (defined $self->{$_}) {
5098             delete $self->{$_};
5099             next KEY;
5100         }
5101         if (ref($self->{$_}) eq "ARRAY") {
5102           push @m, sprintf "    %-12s %s\n", $_, "@{$self->{$_}}";
5103         } elsif (ref($self->{$_}) eq "HASH") {
5104             my $value;
5105             if (/^CONTAINSMODS$/) {
5106                 $value = join(" ",sort keys %{$self->{$_}});
5107             } elsif (/^prereq_pm$/) {
5108                 my @value;
5109                 my $v = $self->{$_};
5110                 for my $x (sort keys %$v) {
5111                     my @svalue;
5112                     for my $y (sort keys %{$v->{$x}}) {
5113                         push @svalue, "$y=>$v->{$x}{$y}";
5114                     }
5115                     push @value, "$x\:" . join ",", @svalue if @svalue;
5116                 }
5117                 $value = join ";", @value;
5118             } else {
5119                 $value = $self->{$_};
5120             }
5121           push @m, sprintf(
5122                            "    %-12s %s\n",
5123                            $_,
5124                            $value,
5125                           );
5126         } else {
5127           push @m, sprintf "    %-12s %s\n", $_, $self->{$_};
5128         }
5129     }
5130     join "", @m, "\n";
5131 }
5132
5133 #-> sub CPAN::InfoObj::fullname ;
5134 sub fullname {
5135     my($self) = @_;
5136     $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
5137 }
5138
5139 #-> sub CPAN::InfoObj::dump ;
5140 sub dump {
5141   my($self, $what) = @_;
5142   unless ($CPAN::META->has_inst("Data::Dumper")) {
5143       $CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
5144   }
5145   local $Data::Dumper::Sortkeys;
5146   $Data::Dumper::Sortkeys = 1;
5147   my $out = Data::Dumper::Dumper($what ? eval $what : $self);
5148   if (length $out > 100000) {
5149       my $fh_pager = FileHandle->new;
5150       local($SIG{PIPE}) = "IGNORE";
5151       my $pager = $CPAN::Config->{'pager'} || "cat";
5152       $fh_pager->open("|$pager")
5153           or die "Could not open pager $pager\: $!";
5154       $fh_pager->print($out);
5155       close $fh_pager;
5156   } else {
5157       $CPAN::Frontend->myprint($out);
5158   }
5159 }
5160
5161 package CPAN::Author;
5162 use strict;
5163
5164 #-> sub CPAN::Author::force
5165 sub force {
5166     my $self = shift;
5167     $self->{force}++;
5168 }
5169
5170 #-> sub CPAN::Author::force
5171 sub unforce {
5172     my $self = shift;
5173     delete $self->{force};
5174 }
5175
5176 #-> sub CPAN::Author::id
5177 sub id {
5178     my $self = shift;
5179     my $id = $self->{ID};
5180     $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
5181     $id;
5182 }
5183
5184 #-> sub CPAN::Author::as_glimpse ;
5185 sub as_glimpse {
5186     my($self) = @_;
5187     my(@m);
5188     my $class = ref($self);
5189     $class =~ s/^CPAN:://;
5190     push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
5191                      $class,
5192                      $self->{ID},
5193                      $self->fullname,
5194                      $self->email);
5195     join "", @m;
5196 }
5197
5198 #-> sub CPAN::Author::fullname ;
5199 sub fullname {
5200     shift->ro->{FULLNAME};
5201 }
5202 *name = \&fullname;
5203
5204 #-> sub CPAN::Author::email ;
5205 sub email    { shift->ro->{EMAIL}; }
5206
5207 #-> sub CPAN::Author::ls ;
5208 sub ls {
5209     my $self = shift;
5210     my $glob = shift || "";
5211     my $silent = shift || 0;
5212     my $id = $self->id;
5213
5214     # adapted from CPAN::Distribution::verifyCHECKSUM ;
5215     my(@csf); # chksumfile
5216     @csf = $self->id =~ /(.)(.)(.*)/;
5217     $csf[1] = join "", @csf[0,1];
5218     $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
5219     my(@dl);
5220     @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
5221     unless (grep {$_->[2] eq $csf[1]} @dl) {
5222         $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
5223         return;
5224     }
5225     @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
5226     unless (grep {$_->[2] eq $csf[2]} @dl) {
5227         $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
5228         return;
5229     }
5230     @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
5231     if ($glob) {
5232         if ($CPAN::META->has_inst("Text::Glob")) {
5233             my $rglob = Text::Glob::glob_to_regex($glob);
5234             @dl = grep { $_->[2] =~ /$rglob/ } @dl;
5235         } else {
5236             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
5237         }
5238     }
5239     $CPAN::Frontend->myprint(join "", map {
5240         sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
5241     } sort { $a->[2] cmp $b->[2] } @dl);
5242     @dl;
5243 }
5244
5245 # returns an array of arrays, the latter contain (size,mtime,filename)
5246 #-> sub CPAN::Author::dir_listing ;
5247 sub dir_listing {
5248     my $self = shift;
5249     my $chksumfile = shift;
5250     my $recursive = shift;
5251     my $may_ftp = shift;
5252
5253     my $lc_want =
5254         File::Spec->catfile($CPAN::Config->{keep_source_where},
5255                             "authors", "id", @$chksumfile);
5256
5257     my $fh;
5258
5259     # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
5260     # hazard.  (Without GPG installed they are not that much better,
5261     # though.)
5262     $fh = FileHandle->new;
5263     if (open($fh, $lc_want)) {
5264         my $line = <$fh>; close $fh;
5265         unlink($lc_want) unless $line =~ /PGP/;
5266     }
5267
5268     local($") = "/";
5269     # connect "force" argument with "index_expire".
5270     my $force = $self->{force};
5271     if (my @stat = stat $lc_want) {
5272         $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
5273     }
5274     my $lc_file;
5275     if ($may_ftp) {
5276         $lc_file = CPAN::FTP->localize(
5277                                        "authors/id/@$chksumfile",
5278                                        $lc_want,
5279                                        $force,
5280                                       );
5281         unless ($lc_file) {
5282             $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
5283             $chksumfile->[-1] .= ".gz";
5284             $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
5285                                            "$lc_want.gz",1);
5286             if ($lc_file) {
5287                 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
5288                 eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
5289             } else {
5290                 return;
5291             }
5292         }
5293     } else {
5294         $lc_file = $lc_want;
5295         # we *could* second-guess and if the user has a file: URL,
5296         # then we could look there. But on the other hand, if they do
5297         # have a file: URL, wy did they choose to set
5298         # $CPAN::Config->{show_upload_date} to false?
5299     }
5300
5301     # adapted from CPAN::Distribution::CHECKSUM_check_file ;
5302     $fh = FileHandle->new;
5303     my($cksum);
5304     if (open $fh, $lc_file){
5305         local($/);
5306         my $eval = <$fh>;
5307         $eval =~ s/\015?\012/\n/g;
5308         close $fh;
5309         my($comp) = Safe->new();
5310         $cksum = $comp->reval($eval);
5311         if ($@) {
5312             rename $lc_file, "$lc_file.bad";
5313             Carp::confess($@) if $@;
5314         }
5315     } elsif ($may_ftp) {
5316         Carp::carp "Could not open '$lc_file' for reading.";
5317     } else {
5318         # Maybe should warn: "You may want to set show_upload_date to a true value"
5319         return;
5320     }
5321     my(@result,$f);
5322     for $f (sort keys %$cksum) {
5323         if (exists $cksum->{$f}{isdir}) {
5324             if ($recursive) {
5325                 my(@dir) = @$chksumfile;
5326                 pop @dir;
5327                 push @dir, $f, "CHECKSUMS";
5328                 push @result, map {
5329                     [$_->[0], $_->[1], "$f/$_->[2]"]
5330                 } $self->dir_listing(\@dir,1,$may_ftp);
5331             } else {
5332                 push @result, [ 0, "-", $f ];
5333             }
5334         } else {
5335             push @result, [
5336                            ($cksum->{$f}{"size"}||0),
5337                            $cksum->{$f}{"mtime"}||"---",
5338                            $f
5339                           ];
5340         }
5341     }
5342     @result;
5343 }
5344
5345 package CPAN::Distribution;
5346 use strict;
5347
5348 # Accessors
5349 sub cpan_comment {
5350     my $self = shift;
5351     my $ro = $self->ro or return;
5352     $ro->{CPAN_COMMENT}
5353 }
5354
5355 # CPAN::Distribution::undelay
5356 sub undelay {
5357     my $self = shift;
5358     delete $self->{later};
5359 }
5360
5361 # add the A/AN/ stuff
5362 # CPAN::Distribution::normalize
5363 sub normalize {
5364     my($self,$s) = @_;
5365     $s = $self->id unless defined $s;
5366     if (substr($s,-1,1) eq ".") {
5367         # using a global because we are sometimes called as static method
5368         if (!$CPAN::META->{LOCK}
5369             && !$CPAN::Have_warned->{"$s is unlocked"}++
5370            ) {
5371             $CPAN::Frontend->mywarn("You are visiting the local directory
5372   '$s'
5373   without lock, take care that concurrent processes do not do likewise.\n");
5374             $CPAN::Frontend->mysleep(1);
5375         }
5376         if ($s eq ".") {
5377             $s = "$CPAN::iCwd/.";
5378         } elsif (File::Spec->file_name_is_absolute($s)) {
5379         } elsif (File::Spec->can("rel2abs")) {
5380             $s = File::Spec->rel2abs($s);
5381         } else {
5382             $CPAN::Frontend->mydie("Your File::Spec is too old, please upgrade File::Spec");
5383         }
5384         CPAN->debug("s[$s]") if $CPAN::DEBUG;
5385         unless ($CPAN::META->exists("CPAN::Distribution", $s)) {
5386             for ($CPAN::META->instance("CPAN::Distribution", $s)) {
5387                 $_->{build_dir} = $s;
5388                 $_->{archived} = "local_directory";
5389                 $_->{unwrapped} = CPAN::Distrostatus->new("YES -- local_directory");
5390             }
5391         }
5392     } elsif (
5393         $s =~ tr|/|| == 1
5394         or
5395         $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
5396        ) {
5397         return $s if $s =~ m:^N/A|^Contact Author: ;
5398         $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
5399             $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
5400         CPAN->debug("s[$s]") if $CPAN::DEBUG;
5401     }
5402     $s;
5403 }
5404
5405 #-> sub CPAN::Distribution::author ;
5406 sub author {
5407     my($self) = @_;
5408     my($authorid);
5409     if (substr($self->id,-1,1) eq ".") {
5410         $authorid = "LOCAL";
5411     } else {
5412         ($authorid) = $self->pretty_id =~ /^([\w\-]+)/;
5413     }
5414     CPAN::Shell->expand("Author",$authorid);
5415 }
5416
5417 # tries to get the yaml from CPAN instead of the distro itself:
5418 # EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels
5419 sub fast_yaml {
5420     my($self) = @_;
5421     my $meta = $self->pretty_id;
5422     $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/;
5423     my(@ls) = CPAN::Shell->globls($meta);
5424     my $norm = $self->normalize($meta);
5425
5426     my($local_file);
5427     my($local_wanted) =
5428         File::Spec->catfile(
5429                             $CPAN::Config->{keep_source_where},
5430                             "authors",
5431                             "id",
5432                             split(/\//,$norm)
5433                            );
5434     $self->debug("Doing localize") if $CPAN::DEBUG;
5435     unless ($local_file =
5436             CPAN::FTP->localize("authors/id/$norm",
5437                                 $local_wanted)) {
5438         $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n");
5439     }
5440     my $yaml = CPAN->_yaml_loadfile($local_file)->[0];
5441 }
5442
5443 #-> sub CPAN::Distribution::cpan_userid
5444 sub cpan_userid {
5445     my $self = shift;
5446     if ($self->{ID} =~ m{[A-Z]/[A-Z\-]{2}/([A-Z\-]+)/}) {
5447         return $1;
5448     }
5449     return $self->SUPER::cpan_userid;
5450 }
5451
5452 #-> sub CPAN::Distribution::pretty_id
5453 sub pretty_id {
5454     my $self = shift;
5455     my $id = $self->id;
5456     return $id unless $id =~ m|^./../|;
5457     substr($id,5);
5458 }
5459
5460 # mark as dirty/clean for the sake of recursion detection. $color=1
5461 # means "in use", $color=0 means "not in use anymore". $color=2 means
5462 # we have determined prereqs now and thus insist on passing this
5463 # through (at least) once again.
5464
5465 #-> sub CPAN::Distribution::color_cmd_tmps ;
5466 sub color_cmd_tmps {
5467     my($self) = shift;
5468     my($depth) = shift || 0;
5469     my($color) = shift || 0;
5470     my($ancestors) = shift || [];
5471     # a distribution needs to recurse into its prereq_pms
5472
5473     return if exists $self->{incommandcolor}
5474         && $color==1
5475         && $self->{incommandcolor}==$color;
5476     if ($depth>=$CPAN::MAX_RECURSION){
5477         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
5478     }
5479     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5480     my $prereq_pm = $self->prereq_pm;
5481     if (defined $prereq_pm) {
5482       PREREQ: for my $pre (keys %{$prereq_pm->{requires}||{}},
5483                            keys %{$prereq_pm->{build_requires}||{}}) {
5484             next PREREQ if $pre eq "perl";
5485             my $premo;
5486             unless ($premo = CPAN::Shell->expand("Module",$pre)) {
5487                 $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n");
5488                 $CPAN::Frontend->mysleep(2);
5489                 next PREREQ;
5490             }
5491             $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5492         }
5493     }
5494     if ($color==0) {
5495         delete $self->{sponsored_mods};
5496
5497         # as we are at the end of a command, we'll give up this
5498         # reminder of a broken test. Other commands may test this guy
5499         # again. Maybe 'badtestcnt' should be renamed to
5500         # 'make_test_failed_within_command'?
5501         delete $self->{badtestcnt};
5502     }
5503     $self->{incommandcolor} = $color;
5504 }
5505
5506 #-> sub CPAN::Distribution::as_string ;
5507 sub as_string {
5508   my $self = shift;
5509   $self->containsmods;
5510   $self->upload_date;
5511   $self->SUPER::as_string(@_);
5512 }
5513
5514 #-> sub CPAN::Distribution::containsmods ;
5515 sub containsmods {
5516   my $self = shift;
5517   return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
5518   my $dist_id = $self->{ID};
5519   for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
5520     my $mod_file = $mod->cpan_file or next;
5521     my $mod_id = $mod->{ID} or next;
5522     # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
5523     # sleep 1;
5524     if ($CPAN::Signal) {
5525         delete $self->{CONTAINSMODS};
5526         return;
5527     }
5528     $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
5529   }
5530   keys %{$self->{CONTAINSMODS}||{}};
5531 }
5532
5533 #-> sub CPAN::Distribution::upload_date ;
5534 sub upload_date {
5535   my $self = shift;
5536   return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
5537   my(@local_wanted) = split(/\//,$self->id);
5538   my $filename = pop @local_wanted;
5539   push @local_wanted, "CHECKSUMS";
5540   my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
5541   return unless $author;
5542   my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
5543   return unless @dl;
5544   my($dirent) = grep { $_->[2] eq $filename } @dl;
5545   # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
5546   return unless $dirent->[1];
5547   return $self->{UPLOAD_DATE} = $dirent->[1];
5548 }
5549
5550 #-> sub CPAN::Distribution::uptodate ;
5551 sub uptodate {
5552     my($self) = @_;
5553     my $c;
5554     foreach $c ($self->containsmods) {
5555         my $obj = CPAN::Shell->expandany($c);
5556         unless ($obj->uptodate){
5557             my $id = $self->pretty_id;
5558             $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG;
5559             return 0;
5560         }
5561     }
5562     return 1;
5563 }
5564
5565 #-> sub CPAN::Distribution::called_for ;
5566 sub called_for {
5567     my($self,$id) = @_;
5568     $self->{CALLED_FOR} = $id if defined $id;
5569     return $self->{CALLED_FOR};
5570 }
5571
5572 #-> sub CPAN::Distribution::get ;
5573 sub get {
5574     my($self) = @_;
5575     $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
5576     if (my $goto = $self->prefs->{goto}) {
5577         $CPAN::Frontend->mywarn
5578             (sprintf(
5579                      "delegating to '%s' as specified in prefs file '%s' doc %d\n",
5580                      $goto,
5581                      $self->{prefs_file},
5582                      $self->{prefs_file_doc},
5583                     ));
5584         return $self->goto($goto);
5585     }
5586     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
5587                            ? $ENV{PERL5LIB}
5588                            : ($ENV{PERLLIB} || "");
5589
5590     $CPAN::META->set_perl5lib;
5591     local $ENV{MAKEFLAGS}; # protect us from outer make calls
5592
5593   EXCUSE: {
5594         my @e;
5595         $self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG;
5596         if ($self->prefs->{disabled}) {
5597             my $why = sprintf(
5598                               "Disabled via prefs file '%s' doc %d",
5599                               $self->{prefs_file},
5600                               $self->{prefs_file_doc},
5601                              );
5602             push @e, $why;
5603             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $why");
5604             # note: not intended to be persistent but at least visible
5605             # during this session
5606         } else {
5607             if (exists $self->{build_dir}) {
5608                 # this deserves print, not warn:
5609                 $CPAN::Frontend->myprint("  Has already been unwrapped into directory ".
5610                                          "$self->{build_dir}\n"
5611                                         );
5612                 return;
5613             }
5614
5615             # although we talk about 'force' we shall not test on
5616             # force directly. New model of force tries to refrain from
5617             # direct checking of force.
5618             exists $self->{unwrapped} and (
5619                                            UNIVERSAL::can($self->{unwrapped},"failed") ?
5620                                            $self->{unwrapped}->failed :
5621                                            $self->{unwrapped} =~ /^NO/
5622                                           )
5623                 and push @e, "Unwrapping had some problem, won't try again without force";
5624         }
5625
5626         $CPAN::Frontend->mywarn(join "", map {"$_\n"} @e) and return if @e;
5627     }
5628     my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
5629
5630     #
5631     # Get the file on local disk
5632     #
5633
5634     my($local_file);
5635     my($local_wanted) =
5636         File::Spec->catfile(
5637                             $CPAN::Config->{keep_source_where},
5638                             "authors",
5639                             "id",
5640                             split(/\//,$self->id)
5641                            );
5642
5643     $self->debug("Doing localize") if $CPAN::DEBUG;
5644     unless ($local_file =
5645             CPAN::FTP->localize("authors/id/$self->{ID}",
5646                                 $local_wanted)) {
5647         my $note = "";
5648         if ($CPAN::Index::DATE_OF_02) {
5649             $note = "Note: Current database in memory was generated ".
5650                 "on $CPAN::Index::DATE_OF_02\n";
5651         }
5652         $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
5653     }
5654
5655     $self->debug("local_wanted[$local_wanted]local_file[$local_file]") if $CPAN::DEBUG;
5656     $self->{localfile} = $local_file;
5657     return if $CPAN::Signal;
5658
5659     #
5660     # Check integrity
5661     #
5662     if ($CPAN::META->has_inst("Digest::SHA")) {
5663         $self->debug("Digest::SHA is installed, verifying");
5664         $self->verifyCHECKSUM;
5665     } else {
5666         $self->debug("Digest::SHA is NOT installed");
5667     }
5668     return if $CPAN::Signal;
5669
5670     #
5671     # Create a clean room and go there
5672     #
5673     $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
5674     my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
5675     $self->safe_chdir($builddir);
5676     $self->debug("Removing tmp-$$") if $CPAN::DEBUG;
5677     File::Path::rmtree("tmp-$$");
5678     unless (mkdir "tmp-$$", 0755) {
5679         $CPAN::Frontend->unrecoverable_error(<<EOF);
5680 Couldn't mkdir '$builddir/tmp-$$': $!
5681
5682 Cannot continue: Please find the reason why I cannot make the
5683 directory
5684 $builddir/tmp-$$
5685 and fix the problem, then retry.
5686
5687 EOF
5688     }
5689     if ($CPAN::Signal){
5690         $self->safe_chdir($sub_wd);
5691         return;
5692     }
5693     $self->safe_chdir("tmp-$$");
5694
5695     #
5696     # Unpack the goods
5697     #
5698     my $ct = eval{CPAN::Tarzip->new($local_file)};
5699     unless ($ct) {
5700         $self->{unwrapped} = CPAN::Distrostatus->new("NO");
5701         delete $self->{build_dir};
5702         return;
5703     }
5704     if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i){
5705         $self->{was_uncompressed}++ unless eval{$ct->gtest()};
5706         $self->untar_me($ct);
5707     } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
5708         $self->unzip_me($ct);
5709     } else {
5710         $self->{was_uncompressed}++ unless $ct->gtest();
5711         $local_file = $self->handle_singlefile($local_file);
5712 #    } else {
5713 #       $self->{archived} = "NO";
5714 #        $self->safe_chdir($sub_wd);
5715 #        return;
5716     }
5717
5718     # we are still in the tmp directory!
5719     # Let's check if the package has its own directory.
5720     my $dh = DirHandle->new(File::Spec->curdir)
5721         or Carp::croak("Couldn't opendir .: $!");
5722     my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
5723     $dh->close;
5724     my ($packagedir);
5725     # XXX here we want in each branch File::Temp to protect all build_dir directories
5726     if (CPAN->has_inst("File::Temp")) {
5727         my $tdir_base;
5728         my $from_dir;
5729         my @dirents;
5730         if (@readdir == 1 && -d $readdir[0]) {
5731             $tdir_base = $readdir[0];
5732             $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]);
5733             my $dh2 = DirHandle->new($from_dir)
5734                 or Carp::croak("Couldn't opendir $from_dir: $!");
5735             @dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC??
5736         } else {
5737             my $userid = $self->cpan_userid;
5738             CPAN->debug("userid[$userid]");
5739             if (!$userid or $userid eq "N/A") {
5740                 $userid = "anon";
5741             }
5742             $tdir_base = $userid;
5743             $from_dir = File::Spec->curdir;
5744             @dirents = @readdir;
5745         }
5746         $packagedir = File::Temp::tempdir(
5747                                           "$tdir_base-XXXXXX",
5748                                           DIR => $builddir,
5749                                           CLEANUP => 0,
5750                                          );
5751         my $f;
5752         for $f (@dirents) { # is already without "." and ".."
5753             my $from = File::Spec->catdir($from_dir,$f);
5754             my $to = File::Spec->catdir($packagedir,$f);
5755             unless (File::Copy::move($from,$to)) {
5756                 my $err = $!;
5757                 $from = File::Spec->rel2abs($from);
5758                 Carp::confess("Couldn't move $from to $to: $err");
5759             }
5760         }
5761     } else { # older code below, still better than nothing when there is no File::Temp
5762         my($distdir);
5763         if (@readdir == 1 && -d $readdir[0]) {
5764             $distdir = $readdir[0];
5765             $packagedir = File::Spec->catdir($builddir,$distdir);
5766             $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
5767                 if $CPAN::DEBUG;
5768             -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
5769                                                         "$packagedir\n");
5770             File::Path::rmtree($packagedir);
5771             unless (File::Copy::move($distdir,$packagedir)) {
5772                 $CPAN::Frontend->unrecoverable_error(<<EOF);
5773 Couldn't move '$distdir' to '$packagedir': $!
5774
5775 Cannot continue: Please find the reason why I cannot move
5776 $builddir/tmp-$$/$distdir
5777 to
5778 $packagedir
5779 and fix the problem, then retry
5780
5781 EOF
5782             }
5783             $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
5784                                  $distdir,
5785                                  $packagedir,
5786                                  -e $packagedir,
5787                                  -d $packagedir,
5788                                 )) if $CPAN::DEBUG;
5789         } else {
5790             my $userid = $self->cpan_userid;
5791             CPAN->debug("userid[$userid]") if $CPAN::DEBUG;
5792             if (!$userid or $userid eq "N/A") {
5793                 $userid = "anon";
5794             }
5795             my $pragmatic_dir = $userid . '000';
5796             $pragmatic_dir =~ s/\W_//g;
5797             $pragmatic_dir++ while -d "../$pragmatic_dir";
5798             $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
5799             $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
5800             File::Path::mkpath($packagedir);
5801             my($f);
5802             for $f (@readdir) { # is already without "." and ".."
5803                 my $to = File::Spec->catdir($packagedir,$f);
5804                 File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
5805             }
5806         }
5807     }
5808     if ($CPAN::Signal){
5809         $self->safe_chdir($sub_wd);
5810         return;
5811     }
5812
5813     $self->{build_dir} = $packagedir;
5814     $self->safe_chdir($builddir);
5815     File::Path::rmtree("tmp-$$");
5816
5817     $self->safe_chdir($packagedir);
5818     $self->_signature_business();
5819     $self->safe_chdir($builddir);
5820     return if $CPAN::Signal;
5821
5822
5823     my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
5824     my($mpl_exists) = -f $mpl;
5825     unless ($mpl_exists) {
5826         # NFS has been reported to have racing problems after the
5827         # renaming of a directory in some environments.
5828         # This trick helps.
5829         $CPAN::Frontend->mysleep(1);
5830         my $mpldh = DirHandle->new($packagedir)
5831             or Carp::croak("Couldn't opendir $packagedir: $!");
5832         $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
5833         $mpldh->close;
5834     }
5835     my $prefer_installer = "eumm"; # eumm|mb
5836     if (-f File::Spec->catfile($packagedir,"Build.PL")) {
5837         if ($mpl_exists) { # they *can* choose
5838             if ($CPAN::META->has_inst("Module::Build")) {
5839                 $prefer_installer = CPAN::HandleConfig->prefs_lookup($self,
5840                                                                      q{prefer_installer});
5841             }
5842         } else {
5843             $prefer_installer = "mb";
5844         }
5845     }
5846     return unless $self->patch;
5847     if (lc($prefer_installer) eq "mb") {
5848         $self->{modulebuild} = 1;
5849     } elsif (! $mpl_exists) {
5850         $self->_edge_cases($mpl,$packagedir,$local_file);
5851     }
5852     if ($self->{build_dir}
5853         &&
5854         $CPAN::Config->{build_dir_reuse}
5855        ) {
5856         $self->store_persistent_state;
5857     }
5858
5859     return $self;
5860 }
5861
5862 #-> CPAN::Distribution::store_persistent_state
5863 sub store_persistent_state {
5864     my($self) = @_;
5865     my $dir = $self->{build_dir};
5866     unless (File::Spec->canonpath(File::Basename::dirname($dir))
5867             eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
5868         $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
5869                                 "will not store persistent state\n");
5870         return;
5871     }
5872     my $file = sprintf "%s.yml", $dir;
5873     my $yaml_module = CPAN::_yaml_module;
5874     if ($CPAN::META->has_inst($yaml_module)) {
5875         CPAN->_yaml_dumpfile(
5876                              $file,
5877                              {
5878                               time => time,
5879                               perl => CPAN::_perl_fingerprint,
5880                               distribution => $self,
5881                              }
5882                             );
5883     } else {
5884         $CPAN::Frontend->myprint("Warning (usually harmless): '$yaml_module' not installed, ".
5885                                 "will not store persistent state\n");
5886     }
5887 }
5888
5889 #-> CPAN::Distribution::patch
5890 sub try_download {
5891     my($self,$patch) = @_;
5892     my $norm = $self->normalize($patch);
5893     my($local_wanted) =
5894         File::Spec->catfile(
5895                             $CPAN::Config->{keep_source_where},
5896                             "authors",
5897                             "id",
5898                             split(/\//,$norm),
5899                             );
5900     $self->debug("Doing localize") if $CPAN::DEBUG;
5901     return CPAN::FTP->localize("authors/id/$norm",
5902                                $local_wanted);
5903 }
5904
5905 #-> CPAN::Distribution::patch
5906 sub patch {
5907     my($self) = @_;
5908     $self->debug("checking patches id[$self->{ID}]") if $CPAN::DEBUG;
5909     my $patches = $self->prefs->{patches};
5910     $patches ||= "";
5911     $self->debug("patches[$patches]") if $CPAN::DEBUG;
5912     if ($patches) {
5913         return unless @$patches;
5914         $self->safe_chdir($self->{build_dir});
5915         CPAN->debug("patches[$patches]") if $CPAN::DEBUG;
5916         my $patchbin = $CPAN::Config->{patch};
5917         unless ($patchbin && length $patchbin) {
5918             $CPAN::Frontend->mydie("No external patch command configured\n\n".
5919                                    "Please run 'o conf init /patch/'\n\n");
5920         }
5921         unless (MM->maybe_command($patchbin)) {
5922             $CPAN::Frontend->mydie("No external patch command available\n\n".
5923                                    "Please run 'o conf init /patch/'\n\n");
5924         }
5925         $patchbin = CPAN::HandleConfig->safe_quote($patchbin);
5926         local $ENV{PATCH_GET} = 0; # shall replace -g0 which is not
5927                                    # supported everywhere (and then,
5928                                    # not ever necessary there)
5929         my $stdpatchargs = "-N --fuzz=3";
5930         my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches");
5931         $CPAN::Frontend->myprint("Going to apply $countedpatches:\n");
5932         for my $patch (@$patches) {
5933             unless (-f $patch) {
5934                 if (my $trydl = $self->try_download($patch)) {
5935                     $patch = $trydl;
5936                 } else {
5937                     my $fail = "Could not find patch '$patch'";
5938                     $CPAN::Frontend->mywarn("$fail; cannot continue\n");
5939                     $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
5940                     delete $self->{build_dir};
5941                     return;
5942                 }
5943             }
5944             $CPAN::Frontend->myprint("  $patch\n");
5945             my $readfh = CPAN::Tarzip->TIEHANDLE($patch);
5946
5947             my $pcommand;
5948             my $ppp = $self->_patch_p_parameter($readfh);
5949             if ($ppp eq "applypatch") {
5950                 $pcommand = "$CPAN::Config->{applypatch} -verbose";
5951             } else {
5952                 my $thispatchargs = join " ", $stdpatchargs, $ppp;
5953                 $pcommand = "$patchbin $thispatchargs";
5954             }
5955
5956             $readfh = CPAN::Tarzip->TIEHANDLE($patch); # open again
5957             my $writefh = FileHandle->new;
5958             $CPAN::Frontend->myprint("  $pcommand\n");
5959             unless (open $writefh, "|$pcommand") {
5960                 my $fail = "Could not fork '$pcommand'";
5961                 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
5962                 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
5963                 delete $self->{build_dir};
5964                 return;
5965             }
5966             while (my $x = $readfh->READLINE) {
5967                 print $writefh $x;
5968             }
5969             unless (close $writefh) {
5970                 my $fail = "Could not apply patch '$patch'";
5971                 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
5972                 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
5973                 delete $self->{build_dir};
5974                 return;
5975             }
5976         }
5977         $self->{patched}++;
5978     }
5979     return 1;
5980 }
5981
5982 sub _patch_p_parameter {
5983     my($self,$fh) = @_;
5984     my $cnt_files   = 0;
5985     my $cnt_p0files = 0;
5986     local($_);
5987     while ($_ = $fh->READLINE) {
5988         if (
5989             $CPAN::Config->{applypatch}
5990             &&
5991             /\#\#\#\# ApplyPatch data follows \#\#\#\#/
5992            ) {
5993             return "applypatch"
5994         }
5995         next unless /^[\*\+]{3}\s(\S+)/;
5996         my $file = $1;
5997         $cnt_files++;
5998         $cnt_p0files++ if -f $file;
5999         CPAN->debug("file[$file]cnt_files[$cnt_files]cnt_p0files[$cnt_p0files]")
6000             if $CPAN::DEBUG;
6001     }
6002     return "-p1" unless $cnt_files;
6003     return $cnt_files==$cnt_p0files ? "-p0" : "-p1";
6004 }
6005
6006 #-> sub CPAN::Distribution::_edge_cases
6007 # with "configure" or "Makefile" or single file scripts
6008 sub _edge_cases {
6009     my($self,$mpl,$packagedir,$local_file) = @_;
6010     $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
6011                          $mpl,
6012                          CPAN::anycwd(),
6013                         )) if $CPAN::DEBUG;
6014     my($configure) = File::Spec->catfile($packagedir,"Configure");
6015     if (-f $configure) {
6016         # do we have anything to do?
6017         $self->{configure} = $configure;
6018     } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
6019         $CPAN::Frontend->mywarn(qq{
6020 Package comes with a Makefile and without a Makefile.PL.
6021 We\'ll try to build it with that Makefile then.
6022 });
6023         $self->{writemakefile} = CPAN::Distrostatus->new("YES");
6024         $CPAN::Frontend->mysleep(2);
6025     } else {
6026         my $cf = $self->called_for || "unknown";
6027         if ($cf =~ m|/|) {
6028             $cf =~ s|.*/||;
6029             $cf =~ s|\W.*||;
6030         }
6031         $cf =~ s|[/\\:]||g;     # risk of filesystem damage
6032         $cf = "unknown" unless length($cf);
6033         $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
6034   (The test -f "$mpl" returned false.)
6035   Writing one on our own (setting NAME to $cf)\a\n});
6036         $self->{had_no_makefile_pl}++;
6037         $CPAN::Frontend->mysleep(3);
6038
6039         # Writing our own Makefile.PL
6040
6041         my $script = "";
6042         if ($self->{archived} eq "maybe_pl") {
6043             my $fh = FileHandle->new;
6044             my $script_file = File::Spec->catfile($packagedir,$local_file);
6045             $fh->open($script_file)
6046                 or Carp::croak("Could not open $script_file: $!");
6047             local $/ = "\n";
6048             # name parsen und prereq
6049             my($state) = "poddir";
6050             my($name, $prereq) = ("", "");
6051             while (<$fh>) {
6052                 if ($state eq "poddir" && /^=head\d\s+(\S+)/) {
6053                     if ($1 eq 'NAME') {
6054                         $state = "name";
6055                     } elsif ($1 eq 'PREREQUISITES') {
6056                         $state = "prereq";
6057                     }
6058                 } elsif ($state =~ m{^(name|prereq)$}) {
6059                     if (/^=/) {
6060                         $state = "poddir";
6061                     } elsif (/^\s*$/) {
6062                         # nop
6063                     } elsif ($state eq "name") {
6064                         if ($name eq "") {
6065                             ($name) = /^(\S+)/;
6066                             $state = "poddir";
6067                         }
6068                     } elsif ($state eq "prereq") {
6069                         $prereq .= $_;
6070                     }
6071                 } elsif (/^=cut\b/) {
6072                     last;
6073                 }
6074             }
6075             $fh->close;
6076
6077             for ($name) {
6078                 s{.*<}{};       # strip X<...>
6079                 s{>.*}{};
6080             }
6081             chomp $prereq;
6082             $prereq = join " ", split /\s+/, $prereq;
6083             my($PREREQ_PM) = join("\n", map {
6084                 s{.*<}{};       # strip X<...>
6085                 s{>.*}{};
6086                 if (/[\s\'\"]/) { # prose?
6087                 } else {
6088                     s/[^\w:]$//; # period?
6089                     " "x28 . "'$_' => 0,";
6090                 }
6091             } split /\s*,\s*/, $prereq);
6092
6093             $script = "
6094               EXE_FILES => ['$name'],
6095               PREREQ_PM => {
6096 $PREREQ_PM
6097                            },
6098 ";
6099             if ($name) {
6100                 my $to_file = File::Spec->catfile($packagedir, $name);
6101                 rename $script_file, $to_file
6102                     or die "Can't rename $script_file to $to_file: $!";
6103             }
6104         }
6105
6106         my $fh = FileHandle->new;
6107         $fh->open(">$mpl")
6108             or Carp::croak("Could not open >$mpl: $!");
6109         $fh->print(
6110                    qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
6111 # because there was no Makefile.PL supplied.
6112 # Autogenerated on: }.scalar localtime().qq{
6113
6114 use ExtUtils::MakeMaker;
6115 WriteMakefile(
6116               NAME => q[$cf],$script
6117              );
6118 });
6119         $fh->close;
6120     }
6121 }
6122
6123 #-> CPAN::Distribution::_signature_business
6124 sub _signature_business {
6125     my($self) = @_;
6126     my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
6127                                                       q{check_sigs});
6128     if ($check_sigs) {
6129         if ($CPAN::META->has_inst("Module::Signature")) {
6130             if (-f "SIGNATURE") {
6131                 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
6132                 my $rv = Module::Signature::verify();
6133                 if ($rv != Module::Signature::SIGNATURE_OK() and
6134                     $rv != Module::Signature::SIGNATURE_MISSING()) {
6135                     $CPAN::Frontend->mywarn(
6136                                             qq{\nSignature invalid for }.
6137                                             qq{distribution file. }.
6138                                             qq{Please investigate.\n\n}
6139                                            );
6140
6141                     my $wrap =
6142                         sprintf(qq{I'd recommend removing %s. Its signature
6143 is invalid. Maybe you have configured your 'urllist' with
6144 a bad URL. Please check this array with 'o conf urllist', and
6145 retry. For more information, try opening a subshell with
6146   look %s
6147 and there run
6148   cpansign -v
6149 },
6150                                 $self->{localfile},
6151                                 $self->pretty_id,
6152                                );
6153                     $self->{signature_verify} = CPAN::Distrostatus->new("NO");
6154                     $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
6155                     $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
6156                 } else {
6157                     $self->{signature_verify} = CPAN::Distrostatus->new("YES");
6158                     $self->debug("Module::Signature has verified") if $CPAN::DEBUG;
6159                 }
6160             } else {
6161                 $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n});
6162             }
6163         } else {
6164             $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
6165         }
6166     }
6167 }
6168
6169 #-> CPAN::Distribution::untar_me ;
6170 sub untar_me {
6171     my($self,$ct) = @_;
6172     $self->{archived} = "tar";
6173     if ($ct->untar()) {
6174         $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6175     } else {
6176         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed");
6177     }
6178 }
6179
6180 # CPAN::Distribution::unzip_me ;
6181 sub unzip_me {
6182     my($self,$ct) = @_;
6183     $self->{archived} = "zip";
6184     if ($ct->unzip()) {
6185         $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6186     } else {
6187         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed");
6188     }
6189     return;
6190 }
6191
6192 sub handle_singlefile {
6193     my($self,$local_file) = @_;
6194
6195     if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ){
6196         $self->{archived} = "pm";
6197     } else {
6198         $self->{archived} = "maybe_pl";
6199     }
6200
6201     my $to = File::Basename::basename($local_file);
6202     if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
6203         if (eval{CPAN::Tarzip->new($local_file)->gunzip($to)}) {
6204             $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6205         } else {
6206             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- uncompressing failed");
6207         }
6208     } else {
6209         File::Copy::cp($local_file,".");
6210         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed");
6211     }
6212     return $to;
6213 }
6214
6215 #-> sub CPAN::Distribution::new ;
6216 sub new {
6217     my($class,%att) = @_;
6218
6219     # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
6220
6221     my $this = { %att };
6222     return bless $this, $class;
6223 }
6224
6225 #-> sub CPAN::Distribution::look ;
6226 sub look {
6227     my($self) = @_;
6228
6229     if ($^O eq 'MacOS') {
6230       $self->Mac::BuildTools::look;
6231       return;
6232     }
6233
6234     if (  $CPAN::Config->{'shell'} ) {
6235         $CPAN::Frontend->myprint(qq{
6236 Trying to open a subshell in the build directory...
6237 });
6238     } else {
6239         $CPAN::Frontend->myprint(qq{
6240 Your configuration does not define a value for subshells.
6241 Please define it with "o conf shell <your shell>"
6242 });
6243         return;
6244     }
6245     my $dist = $self->id;
6246     my $dir;
6247     unless ($dir = $self->dir) {
6248         $self->get;
6249     }
6250     unless ($dir ||= $self->dir) {
6251         $CPAN::Frontend->mywarn(qq{
6252 Could not determine which directory to use for looking at $dist.
6253 });
6254         return;
6255     }
6256     my $pwd  = CPAN::anycwd();
6257     $self->safe_chdir($dir);
6258     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
6259     {
6260         local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
6261         $ENV{CPAN_SHELL_LEVEL} += 1;
6262         my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'});
6263         unless (system($shell) == 0) {
6264             my $code = $? >> 8;
6265             $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
6266         }
6267     }
6268     $self->safe_chdir($pwd);
6269 }
6270
6271 # CPAN::Distribution::cvs_import ;
6272 sub cvs_import {
6273     my($self) = @_;
6274     $self->get;
6275     my $dir = $self->dir;
6276
6277     my $package = $self->called_for;
6278     my $module = $CPAN::META->instance('CPAN::Module', $package);
6279     my $version = $module->cpan_version;
6280
6281     my $userid = $self->cpan_userid;
6282
6283     my $cvs_dir = (split /\//, $dir)[-1];
6284     $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
6285     my $cvs_root =
6286       $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
6287     my $cvs_site_perl =
6288       $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
6289     if ($cvs_site_perl) {
6290         $cvs_dir = "$cvs_site_perl/$cvs_dir";
6291     }
6292     my $cvs_log = qq{"imported $package $version sources"};
6293     $version =~ s/\./_/g;
6294     # XXX cvs: undocumented and unclear how it was meant to work
6295     my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
6296                "$cvs_dir", $userid, "v$version");
6297
6298     my $pwd  = CPAN::anycwd();
6299     chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
6300
6301     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
6302
6303     $CPAN::Frontend->myprint(qq{@cmd\n});
6304     system(@cmd) == 0 or
6305     # XXX cvs
6306         $CPAN::Frontend->mydie("cvs import failed");
6307     chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
6308 }
6309
6310 #-> sub CPAN::Distribution::readme ;
6311 sub readme {
6312     my($self) = @_;
6313     my($dist) = $self->id;
6314     my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
6315     $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
6316     my($local_file);
6317     my($local_wanted) =
6318          File::Spec->catfile(
6319                              $CPAN::Config->{keep_source_where},
6320                              "authors",
6321                              "id",
6322                              split(/\//,"$sans.readme"),
6323                             );
6324     $self->debug("Doing localize") if $CPAN::DEBUG;
6325     $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
6326                                       $local_wanted)
6327         or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
6328
6329     if ($^O eq 'MacOS') {
6330         Mac::BuildTools::launch_file($local_file);
6331         return;
6332     }
6333
6334     my $fh_pager = FileHandle->new;
6335     local($SIG{PIPE}) = "IGNORE";
6336     my $pager = $CPAN::Config->{'pager'} || "cat";
6337     $fh_pager->open("|$pager")
6338         or die "Could not open pager $pager\: $!";
6339     my $fh_readme = FileHandle->new;
6340     $fh_readme->open($local_file)
6341         or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
6342     $CPAN::Frontend->myprint(qq{
6343 Displaying file
6344   $local_file
6345 with pager "$pager"
6346 });
6347     $fh_pager->print(<$fh_readme>);
6348     $fh_pager->close;
6349 }
6350
6351 #-> sub CPAN::Distribution::verifyCHECKSUM ;
6352 sub verifyCHECKSUM {
6353     my($self) = @_;
6354   EXCUSE: {
6355         my @e;
6356         $self->{CHECKSUM_STATUS} ||= "";
6357         $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
6358         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
6359     }
6360     my($lc_want,$lc_file,@local,$basename);
6361     @local = split(/\//,$self->id);
6362     pop @local;
6363     push @local, "CHECKSUMS";
6364     $lc_want =
6365         File::Spec->catfile($CPAN::Config->{keep_source_where},
6366                             "authors", "id", @local);
6367     local($") = "/";
6368     if (my $size = -s $lc_want) {
6369         $self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG;
6370         if ($self->CHECKSUM_check_file($lc_want,1)) {
6371             return $self->{CHECKSUM_STATUS} = "OK";
6372         }
6373     }
6374     $lc_file = CPAN::FTP->localize("authors/id/@local",
6375                                    $lc_want,1);
6376     unless ($lc_file) {
6377         $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
6378         $local[-1] .= ".gz";
6379         $lc_file = CPAN::FTP->localize("authors/id/@local",
6380                                        "$lc_want.gz",1);
6381         if ($lc_file) {
6382             $lc_file =~ s/\.gz(?!\n)\Z//;
6383             eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
6384         } else {
6385             return;
6386         }
6387     }
6388     if ($self->CHECKSUM_check_file($lc_file)) {
6389         return $self->{CHECKSUM_STATUS} = "OK";
6390     }
6391 }
6392
6393 #-> sub CPAN::Distribution::SIG_check_file ;
6394 sub SIG_check_file {
6395     my($self,$chk_file) = @_;
6396     my $rv = eval { Module::Signature::_verify($chk_file) };
6397
6398     if ($rv == Module::Signature::SIGNATURE_OK()) {
6399         $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
6400         return $self->{SIG_STATUS} = "OK";
6401     } else {
6402         $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
6403                                  qq{distribution file. }.
6404                                  qq{Please investigate.\n\n}.
6405                                  $self->as_string,
6406                                 $CPAN::META->instance(
6407                                                         'CPAN::Author',
6408                                                         $self->cpan_userid
6409                                                         )->as_string);
6410
6411         my $wrap = qq{I\'d recommend removing $chk_file. Its signature
6412 is invalid. Maybe you have configured your 'urllist' with
6413 a bad URL. Please check this array with 'o conf urllist', and
6414 retry.};
6415
6416         $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
6417     }
6418 }
6419
6420 #-> sub CPAN::Distribution::CHECKSUM_check_file ;
6421
6422 # sloppy is 1 when we have an old checksums file that maybe is good
6423 # enough
6424
6425 sub CHECKSUM_check_file {
6426     my($self,$chk_file,$sloppy) = @_;
6427     my($cksum,$file,$basename);
6428
6429     $sloppy ||= 0;
6430     $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG;
6431     my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
6432                                                       q{check_sigs});
6433     if ($check_sigs) {
6434         if ($CPAN::META->has_inst("Module::Signature")) {
6435             $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
6436             $self->SIG_check_file($chk_file);
6437         } else {
6438             $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
6439         }
6440     }
6441
6442     $file = $self->{localfile};
6443     $basename = File::Basename::basename($file);
6444     my $fh = FileHandle->new;
6445     if (open $fh, $chk_file){
6446         local($/);
6447         my $eval = <$fh>;
6448         $eval =~ s/\015?\012/\n/g;
6449         close $fh;
6450         my($comp) = Safe->new();
6451         $cksum = $comp->reval($eval);
6452         if ($@) {
6453             rename $chk_file, "$chk_file.bad";
6454             Carp::confess($@) if $@;
6455         }
6456     } else {
6457         Carp::carp "Could not open $chk_file for reading";
6458     }
6459
6460     if (! ref $cksum or ref $cksum ne "HASH") {
6461         $CPAN::Frontend->mywarn(qq{
6462 Warning: checksum file '$chk_file' broken.
6463
6464 When trying to read that file I expected to get a hash reference
6465 for further processing, but got garbage instead.
6466 });
6467         my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
6468         $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
6469         $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken";
6470         return;
6471     } elsif (exists $cksum->{$basename}{sha256}) {
6472         $self->debug("Found checksum for $basename:" .
6473                      "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
6474
6475         open($fh, $file);
6476         binmode $fh;
6477         my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
6478         $fh->close;
6479         $fh = CPAN::Tarzip->TIEHANDLE($file);
6480
6481         unless ($eq) {
6482           my $dg = Digest::SHA->new(256);
6483           my($data,$ref);
6484           $ref = \$data;
6485           while ($fh->READ($ref, 4096) > 0){
6486             $dg->add($data);
6487           }
6488           my $hexdigest = $dg->hexdigest;
6489           $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
6490         }
6491
6492         if ($eq) {
6493           $CPAN::Frontend->myprint("Checksum for $file ok\n");
6494           return $self->{CHECKSUM_STATUS} = "OK";
6495         } else {
6496             $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
6497                                      qq{distribution file. }.
6498                                      qq{Please investigate.\n\n}.
6499                                      $self->as_string,
6500                                      $CPAN::META->instance(
6501                                                            'CPAN::Author',
6502                                                            $self->cpan_userid
6503                                                           )->as_string);
6504
6505             my $wrap = qq{I\'d recommend removing $file. Its
6506 checksum is incorrect. Maybe you have configured your 'urllist' with
6507 a bad URL. Please check this array with 'o conf urllist', and
6508 retry.};
6509
6510             $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
6511
6512             # former versions just returned here but this seems a
6513             # serious threat that deserves a die
6514
6515             # $CPAN::Frontend->myprint("\n\n");
6516             # sleep 3;
6517             # return;
6518         }
6519         # close $fh if fileno($fh);
6520     } else {
6521         return if $sloppy;
6522         unless ($self->{CHECKSUM_STATUS}) {
6523             $CPAN::Frontend->mywarn(qq{
6524 Warning: No checksum for $basename in $chk_file.
6525
6526 The cause for this may be that the file is very new and the checksum
6527 has not yet been calculated, but it may also be that something is
6528 going awry right now.
6529 });
6530             my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes");
6531             $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
6532         }
6533         $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file";
6534         return;
6535     }
6536 }
6537
6538 #-> sub CPAN::Distribution::eq_CHECKSUM ;
6539 sub eq_CHECKSUM {
6540     my($self,$fh,$expect) = @_;
6541     if ($CPAN::META->has_inst("Digest::SHA")) {
6542         my $dg = Digest::SHA->new(256);
6543         my($data);
6544         while (read($fh, $data, 4096)){
6545             $dg->add($data);
6546         }
6547         my $hexdigest = $dg->hexdigest;
6548         # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
6549         return $hexdigest eq $expect;
6550     }
6551     return 1;
6552 }
6553
6554 #-> sub CPAN::Distribution::force ;
6555
6556 # Both CPAN::Modules and CPAN::Distributions know if "force" is in
6557 # effect by autoinspection, not by inspecting a global variable. One
6558 # of the reason why this was chosen to work that way was the treatment
6559 # of dependencies. They should not automatically inherit the force
6560 # status. But this has the downside that ^C and die() will return to
6561 # the prompt but will not be able to reset the force_update
6562 # attributes. We try to correct for it currently in the read_metadata
6563 # routine, and immediately before we check for a Signal. I hope this
6564 # works out in one of v1.57_53ff
6565
6566 # "Force get forgets previous error conditions"
6567
6568 #-> sub CPAN::Distribution::fforce ;
6569 sub fforce {
6570   my($self, $method) = @_;
6571   $self->force($method,1);
6572 }
6573
6574 #-> sub CPAN::Distribution::force ;
6575 sub force {
6576   my($self, $method,$fforce) = @_;
6577   my %phase_map = (
6578                    get => [
6579                            "unwrapped",
6580                            "build_dir",
6581                            "archived",
6582                            "localfile",
6583                            "CHECKSUM_STATUS",
6584                            "signature_verify",
6585                            "prefs",
6586                            "prefs_file",
6587                            "prefs_file_doc",
6588                           ],
6589                    make => [
6590                             "writemakefile",
6591                             "make",
6592                             "modulebuild",
6593                             "prereq_pm",
6594                             "prereq_pm_detected",
6595                            ],
6596                    test => [
6597                             "badtestcnt",
6598                             "make_test",
6599                            ],
6600                    install => [
6601                                "install",
6602                               ],
6603                    unknown => [
6604                                "reqtype",
6605                                "yaml_content",
6606                               ],
6607                   );
6608   my $methodmatch = 0;
6609   my $ldebug = 0;
6610  PHASE: for my $phase (qw(unknown get make test install)) { # order matters
6611       $methodmatch = 1 if $fforce || $phase eq $method;
6612       next unless $methodmatch;
6613     ATTRIBUTE: for my $att (@{$phase_map{$phase}}) {
6614           if ($phase eq "get") {
6615               if (substr($self->id,-1,1) eq "."
6616                   && $att =~ /(unwrapped|build_dir|archived)/ ) {
6617                   # cannot be undone for local distros
6618                   next ATTRIBUTE;
6619               }
6620               if ($att eq "build_dir"
6621                   && $self->{build_dir}
6622                   && $CPAN::META->{is_tested}
6623                  ) {
6624                   delete $CPAN::META->{is_tested}{$self->{build_dir}};
6625               }
6626           } elsif ($phase eq "test") {
6627               if ($att eq "make_test"
6628                   && $self->{make_test}
6629                   && $self->{make_test}{COMMANDID}
6630                   && $self->{make_test}{COMMANDID} == $CPAN::CurrentCommandId
6631                  ) {
6632                   # endless loop too likely
6633                   next ATTRIBUTE;
6634               }
6635           }
6636           delete $self->{$att};
6637           if ($ldebug || $CPAN::DEBUG) {
6638               # local $CPAN::DEBUG = 16; # Distribution
6639               CPAN->debug(sprintf "id[%s]phase[%s]att[%s]", $self->id, $phase, $att);
6640           }
6641       }
6642   }
6643   if ($method && $method =~ /make|test|install/) {
6644     $self->{force_update} = 1; # name should probably have been force_install
6645   }
6646 }
6647
6648 #-> sub CPAN::Distribution::notest ;
6649 sub notest {
6650   my($self, $method) = @_;
6651   # warn "XDEBUG: set notest for $self $method";
6652   $self->{"notest"}++; # name should probably have been force_install
6653 }
6654
6655 #-> sub CPAN::Distribution::unnotest ;
6656 sub unnotest {
6657   my($self) = @_;
6658   # warn "XDEBUG: deleting notest";
6659   delete $self->{'notest'};
6660 }
6661
6662 #-> sub CPAN::Distribution::unforce ;
6663 sub unforce {
6664   my($self) = @_;
6665   delete $self->{force_update};
6666 }
6667
6668 #-> sub CPAN::Distribution::isa_perl ;
6669 sub isa_perl {
6670   my($self) = @_;
6671   my $file = File::Basename::basename($self->id);
6672   if ($file =~ m{ ^ perl
6673                   -?
6674                   (5)
6675                   ([._-])
6676                   (
6677                    \d{3}(_[0-4][0-9])?
6678                    |
6679                    \d+\.\d+
6680                   )
6681                   \.tar[._-](?:gz|bz2)
6682                   (?!\n)\Z
6683                 }xs){
6684     return "$1.$3";
6685   } elsif ($self->cpan_comment
6686            &&
6687            $self->cpan_comment =~ /isa_perl\(.+?\)/){
6688     return $1;
6689   }
6690 }
6691
6692
6693 #-> sub CPAN::Distribution::perl ;
6694 sub perl {
6695     my ($self) = @_;
6696     if (! $self) {
6697         use Carp qw(carp);
6698         carp __PACKAGE__ . "::perl was called without parameters.";
6699     }
6700     return CPAN::HandleConfig->safe_quote($CPAN::Perl);
6701 }
6702
6703
6704 #-> sub CPAN::Distribution::make ;
6705 sub make {
6706     my($self) = @_;
6707     if (my $goto = $self->prefs->{goto}) {
6708         return $self->goto($goto);
6709     }
6710     my $make = $self->{modulebuild} ? "Build" : "make";
6711     # Emergency brake if they said install Pippi and get newest perl
6712     if ($self->isa_perl) {
6713       if (
6714           $self->called_for ne $self->id &&
6715           ! $self->{force_update}
6716          ) {
6717         # if we die here, we break bundles
6718         $CPAN::Frontend
6719             ->mywarn(sprintf(
6720                              qq{The most recent version "%s" of the module "%s"
6721 is part of the perl-%s distribution. To install that, you need to run
6722   force install %s   --or--
6723   install %s
6724 },
6725                              $CPAN::META->instance(
6726                                                    'CPAN::Module',
6727                                                    $self->called_for
6728                                                   )->cpan_version,
6729                              $self->called_for,
6730                              $self->isa_perl,
6731                              $self->called_for,
6732                              $self->id,
6733                             ));
6734         $self->{make} = CPAN::Distrostatus->new("NO isa perl");
6735         $CPAN::Frontend->mysleep(1);
6736         return;
6737       }
6738     }
6739     $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
6740     $self->get;
6741     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
6742                            ? $ENV{PERL5LIB}
6743                            : ($ENV{PERLLIB} || "");
6744     $CPAN::META->set_perl5lib;
6745     local $ENV{MAKEFLAGS}; # protect us from outer make calls
6746
6747     if ($CPAN::Signal){
6748       delete $self->{force_update};
6749       return;
6750     }
6751
6752     my $builddir;
6753   EXCUSE: {
6754         my @e;
6755         if (!$self->{archived} || $self->{archived} eq "NO") {
6756             push @e, "Is neither a tar nor a zip archive.";
6757         }
6758
6759         if (!$self->{unwrapped}
6760             || (
6761                 UNIVERSAL::can($self->{unwrapped},"failed") ?
6762                 $self->{unwrapped}->failed :
6763                 $self->{unwrapped} =~ /^NO/
6764                )) {
6765             push @e, "Had problems unarchiving. Please build manually";
6766         }
6767
6768         unless ($self->{force_update}) {
6769             exists $self->{signature_verify} and
6770                 (
6771                  UNIVERSAL::can($self->{signature_verify},"failed") ?
6772                  $self->{signature_verify}->failed :
6773                  $self->{signature_verify} =~ /^NO/
6774                 )
6775                 and push @e, "Did not pass the signature test.";
6776         }
6777
6778         if (exists $self->{writemakefile} &&
6779             (
6780              UNIVERSAL::can($self->{writemakefile},"failed") ?
6781              $self->{writemakefile}->failed :
6782              $self->{writemakefile} =~ /^NO/
6783             )) {
6784             # XXX maybe a retry would be in order?
6785             my $err = UNIVERSAL::can($self->{writemakefile},"text") ?
6786                 $self->{writemakefile}->text :
6787                     $self->{writemakefile};
6788             $err =~ s/^NO\s*//;
6789             $err ||= "Had some problem writing Makefile";
6790             $err .= ", won't make";
6791             push @e, $err;
6792         }
6793
6794         defined $self->{make} and push @e,
6795             "Has already been made";
6796
6797         if (exists $self->{later} and length($self->{later})) {
6798             if ($self->unsat_prereq) {
6799                 push @e, $self->{later};
6800 # RT ticket 18438 raises doubts if the deletion of {later} is valid.
6801 # YAML-0.53 triggered the later hodge-podge here, but my margin notes
6802 # are not sufficient to be sure if we really must/may do the delete
6803 # here. SO I accept the suggested patch for now. If we trigger a bug
6804 # again, I must go into deep contemplation about the {later} flag.
6805
6806 #            } else {
6807 #                delete $self->{later};
6808             }
6809         }
6810
6811         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
6812         $builddir = $self->dir or
6813             $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
6814         unless (chdir $builddir) {
6815             push @e, "Couldn't chdir to '$builddir': $!";
6816         }
6817         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
6818     }
6819     if ($CPAN::Signal){
6820       delete $self->{force_update};
6821       return;
6822     }
6823     $CPAN::Frontend->myprint("\n  CPAN.pm: Going to build ".$self->id."\n\n");
6824     $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
6825
6826     if ($^O eq 'MacOS') {
6827         Mac::BuildTools::make($self);
6828         return;
6829     }
6830
6831     my %env;
6832     while (my($k,$v) = each %ENV) {
6833         next unless defined $v;
6834         $env{$k} = $v;
6835     }
6836     local %ENV = %env;
6837     my $system;
6838     if (my $commandline = $self->prefs->{pl}{commandline}) {
6839         $system = $commandline;
6840         $ENV{PERL} = $^X;
6841     } elsif ($self->{'configure'}) {
6842         $system = $self->{'configure'};
6843     } elsif ($self->{modulebuild}) {
6844         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
6845         $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}";
6846     } else {
6847         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
6848         my $switch = "";
6849 # This needs a handler that can be turned on or off:
6850 #       $switch = "-MExtUtils::MakeMaker ".
6851 #           "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
6852 #           if $] > 5.00310;
6853         my $makepl_arg = $self->make_x_arg("pl");
6854         $system = sprintf("%s%s Makefile.PL%s",
6855                           $perl,
6856                           $switch ? " $switch" : "",
6857                           $makepl_arg ? " $makepl_arg" : "",
6858                          );
6859     }
6860     if (my $env = $self->prefs->{pl}{env}) {
6861         for my $e (keys %$env) {
6862             $ENV{$e} = $env->{$e};
6863         }
6864     }
6865     if (exists $self->{writemakefile}) {
6866     } else {
6867         local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
6868         my($ret,$pid);
6869         $@ = "";
6870         my $go_via_alarm;
6871         if ($CPAN::Config->{inactivity_timeout}) {
6872             require Config;
6873             if ($Config::Config{d_alarm}
6874                 &&
6875                 $Config::Config{d_alarm} eq "define"
6876                ) {
6877                 $go_via_alarm++
6878             } else {
6879                 $CPAN::Frontend->mywarn("Warning: you have configured the config ".
6880                                         "variable 'inactivity_timeout' to ".
6881                                         "'$CPAN::Config->{inactivity_timeout}'. But ".
6882                                         "on this machine the system call 'alarm' ".
6883                                         "isn't available. This means that we cannot ".
6884                                         "provide the feature of intercepting long ".
6885                                         "waiting code and will turn this feature off.\n"
6886                                        );
6887                 $CPAN::Config->{inactivity_timeout} = 0;
6888             }
6889         }
6890         if ($go_via_alarm) {
6891             eval {
6892                 alarm $CPAN::Config->{inactivity_timeout};
6893                 local $SIG{CHLD}; # = sub { wait };
6894                 if (defined($pid = fork)) {
6895                     if ($pid) { #parent
6896                         # wait;
6897                         waitpid $pid, 0;
6898                     } else {    #child
6899                         # note, this exec isn't necessary if
6900                         # inactivity_timeout is 0. On the Mac I'd
6901                         # suggest, we set it always to 0.
6902                         exec $system;
6903                     }
6904                 } else {
6905                     $CPAN::Frontend->myprint("Cannot fork: $!");
6906                     return;
6907                 }
6908             };
6909             alarm 0;
6910             if ($@){
6911                 kill 9, $pid;
6912                 waitpid $pid, 0;
6913                 my $err = "$@";
6914                 $CPAN::Frontend->myprint($err);
6915                 $self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
6916                 $@ = "";
6917                 return;
6918             }
6919         } else {
6920             if (my $expect_model = $self->_prefs_with_expect("pl")) {
6921                 $ret = $self->_run_via_expect($system,$expect_model);
6922                 if (! defined $ret
6923                     && $self->{writemakefile}
6924                     && $self->{writemakefile}->failed) {
6925                     # timeout
6926                     return;
6927                 }
6928             } else {
6929                 $ret = system($system);
6930             }
6931             if ($ret != 0) {
6932                 $self->{writemakefile} = CPAN::Distrostatus
6933                     ->new("NO '$system' returned status $ret");
6934                 $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
6935                 $self->store_persistent_state;
6936                 $self->store_persistent_state;
6937                 return;
6938             }
6939         }
6940         if (-f "Makefile" || -f "Build") {
6941           $self->{writemakefile} = CPAN::Distrostatus->new("YES");
6942           delete $self->{make_clean}; # if cleaned before, enable next
6943         } else {
6944           $self->{writemakefile} = CPAN::Distrostatus
6945               ->new(qq{NO -- Unknown reason});
6946         }
6947     }
6948     if ($CPAN::Signal){
6949       delete $self->{force_update};
6950       return;
6951     }
6952     if (my @prereq = $self->unsat_prereq){
6953         if ($prereq[0][0] eq "perl") {
6954             my $need = "requires perl '$prereq[0][1]'";
6955             my $id = $self->pretty_id;
6956             $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
6957             $self->{make} = CPAN::Distrostatus->new("NO $need");
6958             $self->store_persistent_state;
6959             return;
6960         } else {
6961             return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
6962         }
6963     }
6964     if ($CPAN::Signal){
6965       delete $self->{force_update};
6966       return;
6967     }
6968     if (my $commandline = $self->prefs->{make}{commandline}) {
6969         $system = $commandline;
6970         $ENV{PERL} = $^X;
6971     } else {
6972         if ($self->{modulebuild}) {
6973             unless (-f "Build") {
6974                 my $cwd = CPAN::anycwd();
6975                 $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
6976                                         " in cwd[$cwd]. Danger, Will Robinson!");
6977                 $CPAN::Frontend->mysleep(5);
6978             }
6979             $system = join " ", $self->_build_command(), $CPAN::Config->{mbuild_arg};
6980         } else {
6981             $system = join " ", $self->_make_command(),  $CPAN::Config->{make_arg};
6982         }
6983         $system =~ s/\s+$//;
6984         my $make_arg = $self->make_x_arg("make");
6985         $system = sprintf("%s%s",
6986                           $system,
6987                           $make_arg ? " $make_arg" : "",
6988                          );
6989     }
6990     if (my $env = $self->prefs->{make}{env}) { # overriding the local
6991                                                # ENV of PL, not the
6992                                                # outer ENV, but
6993                                                # unlikely to be a risk
6994         for my $e (keys %$env) {
6995             $ENV{$e} = $env->{$e};
6996         }
6997     }
6998     my $expect_model = $self->_prefs_with_expect("make");
6999     my $want_expect = 0;
7000     if ( $expect_model && @{$expect_model->{talk}} ) {
7001         my $can_expect = $CPAN::META->has_inst("Expect");
7002         if ($can_expect) {
7003             $want_expect = 1;
7004         } else {
7005             $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
7006                                     "system()\n");
7007         }
7008     }
7009     my $system_ok;
7010     if ($want_expect) {
7011         $system_ok = $self->_run_via_expect($system,$expect_model) == 0;
7012     } else {
7013         $system_ok = system($system) == 0;
7014     }
7015     $self->introduce_myself;
7016     if ( $system_ok ) {
7017          $CPAN::Frontend->myprint("  $system -- OK\n");
7018          $self->{make} = CPAN::Distrostatus->new("YES");
7019     } else {
7020          $self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
7021          $self->{make} = CPAN::Distrostatus->new("NO");
7022          $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
7023     }
7024     $self->store_persistent_state;
7025 }
7026
7027 # CPAN::Distribution::_run_via_expect
7028 sub _run_via_expect {
7029     my($self,$system,$expect_model) = @_;
7030     CPAN->debug("system[$system]expect_model[$expect_model]") if $CPAN::DEBUG;
7031     if ($CPAN::META->has_inst("Expect")) {
7032         my $expo = Expect->new;  # expo Expect object;
7033         $expo->spawn($system);
7034         $expect_model->{mode} ||= "deterministic";
7035         if ($expect_model->{mode} eq "deterministic") {
7036             return $self->_run_via_expect_deterministic($expo,$expect_model);
7037         } elsif ($expect_model->{mode} eq "anyorder") {
7038             return $self->_run_via_expect_anyorder($expo,$expect_model);
7039         } else {
7040             die "Panic: Illegal expect mode: $expect_model->{mode}";
7041         }
7042     } else {
7043         $CPAN::Frontend->mywarn("Expect not installed, falling back to system()\n");
7044         return system($system);
7045     }
7046 }
7047
7048 sub _run_via_expect_anyorder {
7049     my($self,$expo,$expect_model) = @_;
7050     my $timeout = $expect_model->{timeout} || 5;
7051     my @expectacopy = @{$expect_model->{talk}}; # we trash it!
7052     my $but = "";
7053   EXPECT: while () {
7054         my($eof,$ran_into_timeout);
7055         my @match = $expo->expect($timeout,
7056                                   [ eof => sub {
7057                                         $eof++;
7058                                     } ],
7059                                   [ timeout => sub {
7060                                         $ran_into_timeout++;
7061                                     } ],
7062                                   -re => eval"qr{.}",
7063                                  );
7064         if ($match[2]) {
7065             $but .= $match[2];
7066         }
7067         $but .= $expo->clear_accum;
7068         if ($eof) {
7069             $expo->soft_close;
7070             return $expo->exitstatus();
7071         } elsif ($ran_into_timeout) {
7072             # warn "DEBUG: they are asking a question, but[$but]";
7073             for (my $i = 0; $i <= $#expectacopy; $i+=2) {
7074                 my($next,$send) = @expectacopy[$i,$i+1];
7075                 my $regex = eval "qr{$next}";
7076                 # warn "DEBUG: will compare with regex[$regex].";
7077                 if ($but =~ /$regex/) {
7078                     # warn "DEBUG: will send send[$send]";
7079                     $expo->send($send);
7080                     splice @expectacopy, $i, 2; # never allow reusing an QA pair
7081                     next EXPECT;
7082                 }
7083             }
7084             my $why = "could not answer a question during the dialog";
7085             $CPAN::Frontend->mywarn("Failing: $why\n");
7086             $self->{writemakefile} =
7087                 CPAN::Distrostatus->new("NO $why");
7088             return;
7089         }
7090     }
7091 }
7092
7093 sub _run_via_expect_deterministic {
7094     my($self,$expo,$expect_model) = @_;
7095     my $ran_into_timeout;
7096     my $timeout = $expect_model->{timeout} || 15; # currently unsettable
7097     my $expecta = $expect_model->{talk};
7098   EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) {
7099         my($re,$send) = @$expecta[$i,$i+1];
7100         CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG;
7101         my $regex = eval "qr{$re}";
7102         $expo->expect($timeout,
7103                       [ eof => sub {
7104                             my $but = $expo->clear_accum;
7105                             $CPAN::Frontend->mywarn("EOF (maybe harmless)
7106 expected[$regex]\nbut[$but]\n\n");
7107                             last EXPECT;
7108                         } ],
7109                       [ timeout => sub {
7110                             my $but = $expo->clear_accum;
7111                             $CPAN::Frontend->mywarn("TIMEOUT
7112 expected[$regex]\nbut[$but]\n\n");
7113                             $ran_into_timeout++;
7114                         } ],
7115                       -re => $regex);
7116         if ($ran_into_timeout){
7117             # note that the caller expects 0 for success
7118             $self->{writemakefile} =
7119                 CPAN::Distrostatus->new("NO timeout during expect dialog");
7120             return;
7121         }
7122         $expo->send($send);
7123     }
7124     $expo->soft_close;
7125     return $expo->exitstatus();
7126 }
7127
7128 #-> CPAN::Distribution::_validate_distropref
7129 sub _validate_distropref {
7130     my($self,@args) = @_;
7131     if (
7132         $CPAN::META->has_inst("CPAN::Kwalify")
7133         &&
7134         $CPAN::META->has_inst("Kwalify")
7135        ) {
7136         eval {CPAN::Kwalify::_validate("distroprefs",@args);};
7137         if ($@) {
7138             $CPAN::Frontend->mywarn($@);
7139         }
7140     } else {
7141         CPAN->debug("not validating '@args'") if $CPAN::DEBUG;
7142     }
7143 }
7144
7145 #-> CPAN::Distribution::_find_prefs
7146 sub _find_prefs {
7147     my($self) = @_;
7148     my $distroid = $self->pretty_id;
7149     #CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG;
7150     my $prefs_dir = $CPAN::Config->{prefs_dir};
7151     eval { File::Path::mkpath($prefs_dir); };
7152     if ($@) {
7153         $CPAN::Frontend->mydie("Cannot create directory $prefs_dir");
7154     }
7155     my $yaml_module = CPAN::_yaml_module;
7156     my @extensions;
7157     if ($CPAN::META->has_inst($yaml_module)) {
7158         push @extensions, "yml";
7159     } else {
7160         my @fallbacks;
7161         if ($CPAN::META->has_inst("Data::Dumper")) {
7162             push @extensions, "dd";
7163             push @fallbacks, "Data::Dumper";
7164         }
7165         if ($CPAN::META->has_inst("Storable")) {
7166             push @extensions, "st";
7167             push @fallbacks, "Storable";
7168         }
7169         if (@fallbacks) {
7170             local $" = " and ";
7171             unless ($self->{have_complained_about_missing_yaml}++) {
7172                 $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back ".
7173                                         "to @fallbacks to read prefs '$prefs_dir'\n");
7174             }
7175         } else {
7176             unless ($self->{have_complained_about_missing_yaml}++) {
7177                 $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot ".
7178                                         "read prefs '$prefs_dir'\n");
7179             }
7180         }
7181     }
7182     if (@extensions) {
7183         my $dh = DirHandle->new($prefs_dir)
7184             or die Carp::croak("Couldn't open '$prefs_dir': $!");
7185       DIRENT: for (sort $dh->read) {
7186             next if $_ eq "." || $_ eq "..";
7187             my $exte = join "|", @extensions;
7188             next unless /\.($exte)$/;
7189             my $thisexte = $1;
7190             my $abs = File::Spec->catfile($prefs_dir, $_);
7191             if (-f $abs) {
7192                 #CPAN->debug(sprintf "abs[%s]", $abs) if $CPAN::DEBUG;
7193                 my @distropref;
7194                 if ($thisexte eq "yml") {
7195                     # need no eval because if we have no YAML we do not try to read *.yml
7196                     #CPAN->debug(sprintf "before yaml load abs[%s]", $abs) if $CPAN::DEBUG;
7197                     @distropref = @{CPAN->_yaml_loadfile($abs)};
7198                     #CPAN->debug(sprintf "after yaml load abs[%s]", $abs) if $CPAN::DEBUG;
7199                 } elsif ($thisexte eq "dd") {
7200                     package CPAN::Eval;
7201                     no strict;
7202                     open FH, "<$abs" or $CPAN::Frontend->mydie("Could not open '$abs': $!");
7203                     local $/;
7204                     my $eval = <FH>;
7205                     close FH;
7206                     eval $eval;
7207                     if ($@) {
7208                         $CPAN::Frontend->mydie("Error in distroprefs file $_\: $@");
7209                     }
7210                     my $i = 1;
7211                     while (${"VAR".$i}) {
7212                         push @distropref, ${"VAR".$i};
7213                         $i++;
7214                     }
7215                 } elsif ($thisexte eq "st") {
7216                     # eval because Storable is never forward compatible
7217                     eval { @distropref = @{scalar Storable::retrieve($abs)}; };
7218                     if ($@) {
7219                         $CPAN::Frontend->mywarn("Error reading distroprefs file ".
7220                                                 "$_, skipping\: $@");
7221                         $CPAN::Frontend->mysleep(4);
7222                         next DIRENT;
7223                     }
7224                 }
7225                 # $DB::single=1;
7226                 #CPAN->debug(sprintf "#distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
7227               ELEMENT: for my $y (0..$#distropref) {
7228                     my $distropref = $distropref[$y];
7229                     $self->_validate_distropref($distropref,$abs,$y);
7230                     my $match = $distropref->{match};
7231                     unless ($match) {
7232                         #CPAN->debug("no 'match' in abs[$abs], skipping") if $CPAN::DEBUG;
7233                         next ELEMENT;
7234                     }
7235                     my $ok = 1;
7236                     # do not take the order of C<keys %$match> because
7237                     # "module" is by far the slowest
7238                     for my $sub_attribute (qw(distribution perl module)) {
7239                         next unless exists $match->{$sub_attribute};
7240                         my $qr = eval "qr{$distropref->{match}{$sub_attribute}}";
7241                         if ($sub_attribute eq "module") {
7242                             my $okm = 0;
7243                             #CPAN->debug(sprintf "distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
7244                             my @modules = $self->containsmods;
7245                             #CPAN->debug(sprintf "modules[%s]", join(",",@modules)) if $CPAN::DEBUG;
7246                           MODULE: for my $module (@modules) {
7247                                 $okm ||= $module =~ /$qr/;
7248                                 last MODULE if $okm;
7249                             }
7250                             $ok &&= $okm;
7251                         } elsif ($sub_attribute eq "distribution") {
7252                             my $okd = $distroid =~ /$qr/;
7253                             $ok &&= $okd;
7254                         } elsif ($sub_attribute eq "perl") {
7255                             my $okp = $^X =~ /$qr/;
7256                             $ok &&= $okp;
7257                         } else {
7258                             $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ".
7259                                                    "unknown sub_attribut '$sub_attribute'. ".
7260                                                    "Please ".
7261                                                    "remove, cannot continue.");
7262                         }
7263                         last if $ok == 0; # short circuit
7264                     }
7265                     #CPAN->debug(sprintf "ok[%d]", $ok) if $CPAN::DEBUG;
7266                     if ($ok) {
7267                         return {
7268                                 prefs => $distropref,
7269                                 prefs_file => $abs,
7270                                 prefs_file_doc => $y,
7271                                };
7272                     }
7273
7274                 }
7275             }
7276         }
7277         $dh->close;
7278     }
7279     return;
7280 }
7281
7282 # CPAN::Distribution::prefs
7283 sub prefs {
7284     my($self) = @_;
7285     if (exists $self->{negative_prefs_cache}
7286         &&
7287         $self->{negative_prefs_cache} != $CPAN::CurrentCommandId
7288        ) {
7289         delete $self->{negative_prefs_cache};
7290         delete $self->{prefs};
7291     }
7292     if (exists $self->{prefs}) {
7293         return $self->{prefs}; # XXX comment out during debugging
7294     }
7295     if ($CPAN::Config->{prefs_dir}) {
7296         CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG;
7297         my $prefs = $self->_find_prefs();
7298         $prefs ||= ""; # avoid warning next line
7299         CPAN->debug("prefs[$prefs]") if $CPAN::DEBUG;
7300         if ($prefs) {
7301             for my $x (qw(prefs prefs_file prefs_file_doc)) {
7302                 $self->{$x} = $prefs->{$x};
7303             }
7304             my $bs = sprintf(
7305                              "%s[%s]",
7306                              File::Basename::basename($self->{prefs_file}),
7307                              $self->{prefs_file_doc},
7308                             );
7309             my $filler1 = "_" x 22;
7310             my $filler2 = int(66 - length($bs))/2;
7311             $filler2 = 0 if $filler2 < 0;
7312             $filler2 = " " x $filler2;
7313             $CPAN::Frontend->myprint("
7314 $filler1 D i s t r o P r e f s $filler1
7315 $filler2 $bs $filler2
7316 ");
7317             $CPAN::Frontend->mysleep(1);
7318             return $self->{prefs};
7319         }
7320     }
7321     $self->{negative_prefs_cache} = $CPAN::CurrentCommandId;
7322     return $self->{prefs} = +{};
7323 }
7324
7325 # CPAN::Distribution::make_x_arg
7326 sub make_x_arg {
7327     my($self, $whixh) = @_;
7328     my $make_x_arg;
7329     my $prefs = $self->prefs;
7330     if (
7331         $prefs
7332         && exists $prefs->{$whixh}
7333         && exists $prefs->{$whixh}{args}
7334         && $prefs->{$whixh}{args}
7335        ) {
7336         $make_x_arg = join(" ",
7337                            map {CPAN::HandleConfig
7338                                  ->safe_quote($_)} @{$prefs->{$whixh}{args}},
7339                           );
7340     }
7341     my $what = sprintf "make%s_arg", $whixh eq "make" ? "" : $whixh;
7342     $make_x_arg ||= $CPAN::Config->{$what};
7343     return $make_x_arg;
7344 }
7345
7346 # CPAN::Distribution::_make_command
7347 sub _make_command {
7348     my ($self) = @_;
7349     if ($self) {
7350         return
7351             CPAN::HandleConfig
7352                 ->safe_quote(
7353                              CPAN::HandleConfig->prefs_lookup($self,
7354                                                               q{make})
7355                              || $Config::Config{make}
7356                              || 'make'
7357                             );
7358     } else {
7359         # Old style call, without object. Deprecated
7360         Carp::confess("CPAN::_make_command() used as function. Don't Do That.");
7361         return
7362           safe_quote(undef,
7363                      CPAN::HandleConfig->prefs_lookup($self,q{make})
7364                      || $CPAN::Config->{make}
7365                      || $Config::Config{make}
7366                      || 'make');
7367     }
7368 }
7369
7370 #-> sub CPAN::Distribution::follow_prereqs ;
7371 sub follow_prereqs {
7372     my($self) = shift;
7373     my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
7374     return unless @prereq_tuples;
7375     my @prereq = map { $_->[0] } @prereq_tuples;
7376     my $pretty_id = $self->pretty_id;
7377     my %map = (
7378                b => "build_requires",
7379                r => "requires",
7380                c => "commandline",
7381               );
7382     my($filler1,$filler2,$filler3,$filler4);
7383     # $DB::single=1;
7384     my $unsat = "Unsatisfied dependencies detected during";
7385     my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id);
7386     {
7387         my $r = int(($w - length($unsat))/2);
7388         my $l = $w - length($unsat) - $r;
7389         $filler1 = "-"x4 . " "x$l;
7390         $filler2 = " "x$r . "-"x4 . "\n";
7391     }
7392     {
7393         my $r = int(($w - length($pretty_id))/2);
7394         my $l = $w - length($pretty_id) - $r;
7395         $filler3 = "-"x4 . " "x$l;
7396         $filler4 = " "x$r . "-"x4 . "\n";
7397     }
7398     $CPAN::Frontend->
7399         myprint("$filler1 $unsat $filler2".
7400                 "$filler3 $pretty_id $filler4".
7401                 join("", map {"    $_->[0] \[$map{$_->[1]}]\n"} @prereq_tuples),
7402                );
7403     my $follow = 0;
7404     if ($CPAN::Config->{prerequisites_policy} eq "follow") {
7405         $follow = 1;
7406     } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
7407         my $answer = CPAN::Shell::colorable_makemaker_prompt(
7408 "Shall I follow them and prepend them to the queue
7409 of modules we are processing right now?", "yes");
7410         $follow = $answer =~ /^\s*y/i;
7411     } else {
7412         local($") = ", ";
7413         $CPAN::Frontend->
7414             myprint("  Ignoring dependencies on modules @prereq\n");
7415     }
7416     if ($follow) {
7417         my $id = $self->id;
7418         # color them as dirty
7419         for my $p (@prereq) {
7420             # warn "calling color_cmd_tmps(0,1)";
7421             my $any = CPAN::Shell->expandany($p);
7422             if ($any) {
7423                 $any->color_cmd_tmps(0,2);
7424             } else {
7425                 $CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$p'\n");
7426                 $CPAN::Frontend->mysleep(2);
7427             }
7428         }
7429         # queue them and re-queue yourself
7430         CPAN::Queue->jumpqueue([$id,$self->{reqtype}],
7431                                reverse @prereq_tuples);
7432         $self->{later} = "Delayed until after prerequisites";
7433         return 1; # signal success to the queuerunner
7434     }
7435 }
7436
7437 #-> sub CPAN::Distribution::unsat_prereq ;
7438 # return ([Foo=>1],[Bar=>1.2]) for normal modules
7439 # return ([perl=>5.008]) if we need a newer perl than we are running under
7440 sub unsat_prereq {
7441     my($self) = @_;
7442     my $prereq_pm = $self->prereq_pm or return;
7443     my(@need);
7444     my %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}});
7445     my @merged = %merged;
7446     CPAN->debug("all merged_prereqs[@merged]") if $CPAN::DEBUG;
7447   NEED: while (my($need_module, $need_version) = each %merged) {
7448         my($available_version,$available_file,$nmo);
7449         if ($need_module eq "perl") {
7450             $available_version = $];
7451             $available_file = $^X;
7452         } else {
7453             $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
7454             next if $nmo->uptodate;
7455             $available_file = $nmo->available_file;
7456
7457             # if they have not specified a version, we accept any installed one
7458             if (not defined $need_version or
7459                 $need_version == 0 or
7460                 $need_version eq "undef") {
7461                 next if defined $available_file;
7462             }
7463
7464             $available_version = $nmo->available_version;
7465         }
7466
7467         # We only want to install prereqs if either they're not installed
7468         # or if the installed version is too old. We cannot omit this
7469         # check, because if 'force' is in effect, nobody else will check.
7470         if (defined $available_file) {
7471             my(@all_requirements) = split /\s*,\s*/, $need_version;
7472             local($^W) = 0;
7473             my $ok = 0;
7474           RQ: for my $rq (@all_requirements) {
7475                 if ($rq =~ s|>=\s*||) {
7476                 } elsif ($rq =~ s|>\s*||) {
7477                     # 2005-12: one user
7478                     if (CPAN::Version->vgt($available_version,$rq)){
7479                         $ok++;
7480                     }
7481                     next RQ;
7482                 } elsif ($rq =~ s|!=\s*||) {
7483                     # 2005-12: no user
7484                     if (CPAN::Version->vcmp($available_version,$rq)){
7485                         $ok++;
7486                         next RQ;
7487                     } else {
7488                         last RQ;
7489                     }
7490                 } elsif ($rq =~ m|<=?\s*|) {
7491                     # 2005-12: no user
7492                     $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n");
7493                     $ok++;
7494                     next RQ;
7495                 }
7496                 if (! CPAN::Version->vgt($rq, $available_version)){
7497                     $ok++;
7498                 }
7499                 CPAN->debug(sprintf("need_module[%s]available_file[%s]".
7500                                     "available_version[%s]rq[%s]ok[%d]",
7501                                     $need_module,
7502                                     $available_file,
7503                                     $available_version,
7504                                     CPAN::Version->readable($rq),
7505                                     $ok,
7506                                    )) if $CPAN::DEBUG;
7507             }
7508             next NEED if $ok == @all_requirements;
7509         }
7510
7511         if ($need_module eq "perl") {
7512             return ["perl", $need_version];
7513         }
7514         if ($self->{sponsored_mods}{$need_module}++){
7515             # We have already sponsored it and for some reason it's still
7516             # not available. So we do ... what??
7517
7518             # if we push it again, we have a potential infinite loop
7519
7520             # The following "next" was a very problematic construct.
7521             # It helped a lot but broke some day and must be replaced.
7522
7523             # We must be able to deal with modules that come again and
7524             # again as a prereq and have themselves prereqs and the
7525             # queue becomes long but finally we would find the correct
7526             # order. The RecursiveDependency check should trigger a
7527             # die when it's becoming too weird. Unfortunately removing
7528             # this next breaks many other things.
7529
7530             # The bug that brought this up is described in Todo under
7531             # "5.8.9 cannot install Compress::Zlib"
7532
7533             # next; # this is the next that must go away
7534
7535             # The following "next NEED" are fine and the error message
7536             # explains well what is going on. For example when the DBI
7537             # fails and consequently DBD::SQLite fails and now we are
7538             # processing CPAN::SQLite. Then we must have a "next" for
7539             # DBD::SQLite. How can we get it and how can we identify
7540             # all other cases we must identify?
7541
7542             my $do = $nmo->distribution;
7543             next NEED unless $do; # not on CPAN
7544           NOSAYER: for my $nosayer (
7545                                     "unwrapped",
7546                                     "writemakefile",
7547                                     "signature_verify",
7548                                     "make",
7549                                     "make_test",
7550                                     "install",
7551                                     "make_clean",
7552                                    ) {
7553                 if (
7554                     $do->{$nosayer}
7555                     &&(UNIVERSAL::can($do->{$nosayer},"failed") ?
7556                        $do->{$nosayer}->failed :
7557                        $do->{$nosayer} =~ /^NO/)
7558                    ) {
7559                     if ($nosayer eq "make_test"
7560                         &&
7561                         $do->{make_test}{COMMANDID} != $CPAN::CurrentCommandId
7562                        ) {
7563                         next NOSAYER;
7564                     }
7565                     $CPAN::Frontend->mywarn("Warning: Prerequisite ".
7566                                             "'$need_module => $need_version' ".
7567                                             "for '$self->{ID}' failed when ".
7568                                             "processing '$do->{ID}' with ".
7569                                             "'$nosayer => $do->{$nosayer}'. Continuing, ".
7570                                             "but chances to succeed are limited.\n"
7571                                            );
7572                     next NEED;
7573                 }
7574             }
7575         }
7576         my $needed_as = exists $prereq_pm->{requires}{$need_module} ? "r" : "b";
7577         push @need, [$need_module,$needed_as];
7578     }
7579     my @unfolded = map { "[".join(",",@$_)."]" } @need;
7580     CPAN->debug("returning from unsat_prereq[@unfolded]") if $CPAN::DEBUG;
7581     @need;
7582 }
7583
7584 #-> sub CPAN::Distribution::read_yaml ;
7585 sub read_yaml {
7586     my($self) = @_;
7587     return $self->{yaml_content} if exists $self->{yaml_content};
7588     my $build_dir = $self->{build_dir};
7589     my $yaml = File::Spec->catfile($build_dir,"META.yml");
7590     $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
7591     return unless -f $yaml;
7592     eval { $self->{yaml_content} = CPAN->_yaml_loadfile($yaml)->[0]; };
7593     if ($@) {
7594         $CPAN::Frontend->mywarn("Could not read ".
7595                                 "'$yaml'. Falling back to other ".
7596                                 "methods to determine prerequisites\n");
7597         return $self->{yaml_content} = undef; # if we die, then we
7598                                               # cannot read YAML's own
7599                                               # META.yml
7600     }
7601     # not "authoritative"
7602     if (not exists $self->{yaml_content}{dynamic_config}
7603         or $self->{yaml_content}{dynamic_config}
7604        ) {
7605         $self->{yaml_content} = undef;
7606     }
7607     $self->debug(sprintf "yaml_content[%s]", $self->{yaml_content} || "UNDEF")
7608         if $CPAN::DEBUG;
7609     return $self->{yaml_content};
7610 }
7611
7612 #-> sub CPAN::Distribution::prereq_pm ;
7613 sub prereq_pm {
7614     my($self) = @_;
7615     $self->{prereq_pm_detected} ||= 0;
7616     CPAN->debug("ID[$self->{ID}]prereq_pm_detected[$self->{prereq_pm_detected}]") if $CPAN::DEBUG;
7617     return $self->{prereq_pm} if $self->{prereq_pm_detected};
7618     return unless $self->{writemakefile}  # no need to have succeeded
7619                                           # but we must have run it
7620         || $self->{modulebuild};
7621     CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
7622                 $self->{writemakefile}||"",
7623                 $self->{modulebuild}||"",
7624                ) if $CPAN::DEBUG;
7625     my($req,$breq);
7626     if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
7627         $req =  $yaml->{requires} || {};
7628         $breq =  $yaml->{build_requires} || {};
7629         undef $req unless ref $req eq "HASH" && %$req;
7630         if ($req) {
7631             if ($yaml->{generated_by} &&
7632                 $yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
7633                 my $eummv = do { local $^W = 0; $1+0; };
7634                 if ($eummv < 6.2501) {
7635                     # thanks to Slaven for digging that out: MM before
7636                     # that could be wrong because it could reflect a
7637                     # previous release
7638                     undef $req;
7639                 }
7640             }
7641             my $areq;
7642             my $do_replace;
7643             while (my($k,$v) = each %{$req||{}}) {
7644                 if ($v =~ /\d/) {
7645                     $areq->{$k} = $v;
7646                 } elsif ($k =~ /[A-Za-z]/ &&
7647                          $v =~ /[A-Za-z]/ &&
7648                          $CPAN::META->exists("Module",$v)
7649                         ) {
7650                     $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
7651                                             "requires hash: $k => $v; I'll take both ".
7652                                             "key and value as a module name\n");
7653                     $CPAN::Frontend->mysleep(1);
7654                     $areq->{$k} = 0;
7655                     $areq->{$v} = 0;
7656                     $do_replace++;
7657                 }
7658             }
7659             $req = $areq if $do_replace;
7660         }
7661     }
7662     unless ($req || $breq) {
7663         my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
7664         my $makefile = File::Spec->catfile($build_dir,"Makefile");
7665         my $fh;
7666         if (-f $makefile
7667             and
7668             $fh = FileHandle->new("<$makefile\0")) {
7669             CPAN->debug("Getting prereq from Makefile") if $CPAN::DEBUG;
7670             local($/) = "\n";
7671             while (<$fh>) {
7672                 last if /MakeMaker post_initialize section/;
7673                 my($p) = m{^[\#]
7674                            \s+PREREQ_PM\s+=>\s+(.+)
7675                        }x;
7676                 next unless $p;
7677                 # warn "Found prereq expr[$p]";
7678
7679                 #  Regexp modified by A.Speer to remember actual version of file
7680                 #  PREREQ_PM hash key wants, then add to
7681                 while ( $p =~ m/(?:\s)([\w\:]+)=>(q\[.*?\]|undef),?/g ){
7682                     # In case a prereq is mentioned twice, complain.
7683                     if ( defined $req->{$1} ) {
7684                         warn "Warning: PREREQ_PM mentions $1 more than once, ".
7685                             "last mention wins";
7686                     }
7687                     my($m,$n) = ($1,$2);
7688                     if ($n =~ /^q\[(.*?)\]$/) {
7689                         $n = $1;
7690                     }
7691                     $req->{$m} = $n;
7692                 }
7693                 last;
7694             }
7695         }
7696     }
7697     unless ($req || $breq) {
7698         my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
7699         my $buildfile = File::Spec->catfile($build_dir,"Build");
7700         if (-f $buildfile) {
7701             CPAN->debug("Found '$buildfile'") if $CPAN::DEBUG;
7702             my $build_prereqs = File::Spec->catfile($build_dir,"_build","prereqs");
7703             if (-f $build_prereqs) {
7704                 CPAN->debug("Getting prerequisites from '$build_prereqs'") if $CPAN::DEBUG;
7705                 my $content = do { local *FH;
7706                                    open FH, $build_prereqs
7707                                        or $CPAN::Frontend->mydie("Could not open ".
7708                                                                  "'$build_prereqs': $!");
7709                                    local $/;
7710                                    <FH>;
7711                                };
7712                 my $bphash = eval $content;
7713                 if ($@) {
7714                 } else {
7715                     $req  = $bphash->{requires} || +{};
7716                     $breq = $bphash->{build_requires} || +{};
7717                 }
7718             }
7719         }
7720     }
7721     if (-f "Build.PL"
7722         && ! -f "Makefile.PL"
7723         && ! exists $req->{"Module::Build"}
7724         && ! $CPAN::META->has_inst("Module::Build")) {
7725         $CPAN::Frontend->mywarn("  Warning: CPAN.pm discovered Module::Build as ".
7726                                 "undeclared prerequisite.\n".
7727                                 "  Adding it now as such.\n"
7728                                );
7729         $CPAN::Frontend->mysleep(5);
7730         $req->{"Module::Build"} = 0;
7731         delete $self->{writemakefile};
7732     }
7733     if ($req || $breq) {
7734         $self->{prereq_pm_detected}++;
7735         return $self->{prereq_pm} = { requires => $req, build_requires => $breq };
7736     }
7737 }
7738
7739 #-> sub CPAN::Distribution::test ;
7740 sub test {
7741     my($self) = @_;
7742     if (my $goto = $self->prefs->{goto}) {
7743         return $self->goto($goto);
7744     }
7745     $self->make;
7746     if ($CPAN::Signal){
7747       delete $self->{force_update};
7748       return;
7749     }
7750     # warn "XDEBUG: checking for notest: $self->{notest} $self";
7751     if ($self->{notest}) {
7752         $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
7753         return 1;
7754     }
7755
7756     my $make = $self->{modulebuild} ? "Build" : "make";
7757
7758     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
7759                            ? $ENV{PERL5LIB}
7760                            : ($ENV{PERLLIB} || "");
7761
7762     $CPAN::META->set_perl5lib;
7763     local $ENV{MAKEFLAGS}; # protect us from outer make calls
7764
7765     $CPAN::Frontend->myprint("Running $make test\n");
7766
7767 #    if (my @prereq = $self->unsat_prereq){
7768 #        if ( $CPAN::DEBUG ) {
7769 #            require Data::Dumper;
7770 #            CPAN->debug(sprintf "unsat_prereq[%s]", Data::Dumper::Dumper(\@prereq));
7771 #        }
7772 #        unless ($prereq[0][0] eq "perl") {
7773 #            return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
7774 #        }
7775 #    }
7776
7777   EXCUSE: {
7778         my @e;
7779         unless (exists $self->{make} or exists $self->{later}) {
7780             push @e,
7781                 "Make had some problems, won't test";
7782         }
7783
7784         exists $self->{make} and
7785             (
7786              UNIVERSAL::can($self->{make},"failed") ?
7787              $self->{make}->failed :
7788              $self->{make} =~ /^NO/
7789             ) and push @e, "Can't test without successful make";
7790
7791         $self->{badtestcnt} ||= 0;
7792         if ($self->{badtestcnt} > 0) {
7793             require Data::Dumper;
7794             CPAN->debug(sprintf "NOREPEAT[%s]", Data::Dumper::Dumper($self)) if $CPAN::DEBUG;
7795             push @e, "Won't repeat unsuccessful test during this command";
7796         }
7797
7798         exists $self->{later} and length($self->{later}) and
7799             push @e, $self->{later};
7800
7801         if (exists $self->{build_dir}) {
7802             if ($CPAN::META->{is_tested}{$self->{build_dir}}
7803                 &&
7804                 exists $self->{make_test}
7805                 &&
7806                 !(
7807                   UNIVERSAL::can($self->{make_test},"failed") ?
7808                   $self->{make_test}->failed :
7809                   $self->{make_test} =~ /^NO/
7810                  )
7811                ) {
7812                 push @e, "Has already been tested successfully";
7813             }
7814         } elsif (!@e) {
7815             push @e, "Has no own directory";
7816         }
7817         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
7818         unless (chdir $self->{build_dir}) {
7819             push @e, "Couldn't chdir to '$self->{build_dir}': $!";
7820         }
7821         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
7822     }
7823     $self->debug("Changed directory to $self->{build_dir}")
7824         if $CPAN::DEBUG;
7825
7826     if ($^O eq 'MacOS') {
7827         Mac::BuildTools::make_test($self);
7828         return;
7829     }
7830
7831     if ($self->{modulebuild}) {
7832         my $v = CPAN::Shell->expand("Module","Test::Harness")->inst_version;
7833         if (CPAN::Version->vlt($v,2.62)) {
7834             $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
7835   '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n});
7836             $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old");
7837             return;
7838         }
7839     }
7840
7841     my $system;
7842     if (my $commandline = $self->prefs->{test}{commandline}) {
7843         $system = $commandline;
7844         $ENV{PERL} = $^X;
7845     } elsif ($self->{modulebuild}) {
7846         $system = sprintf "%s test", $self->_build_command();
7847     } else {
7848         $system = join " ", $self->_make_command(), "test";
7849     }
7850     my $make_test_arg = $self->make_x_arg("test");
7851     $system = sprintf("%s%s",
7852                       $system,
7853                       $make_test_arg ? " $make_test_arg" : "",
7854                      );
7855     my($tests_ok);
7856     my %env;
7857     while (my($k,$v) = each %ENV) {
7858         next unless defined $v;
7859         $env{$k} = $v;
7860     }
7861     local %ENV = %env;
7862     if (my $env = $self->prefs->{test}{env}) {
7863         for my $e (keys %$env) {
7864             $ENV{$e} = $env->{$e};
7865         }
7866     }
7867     my $expect_model = $self->_prefs_with_expect("test");
7868     my $want_expect = 0;
7869     if ( $expect_model && @{$expect_model->{talk}} ) {
7870         my $can_expect = $CPAN::META->has_inst("Expect");
7871         if ($can_expect) {
7872             $want_expect = 1;
7873         } else {
7874             $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
7875                                     "testing without\n");
7876         }
7877     }
7878     my $test_report = CPAN::HandleConfig->prefs_lookup($self,
7879                                                        q{test_report});
7880     my $want_report;
7881     if ($test_report) {
7882         my $can_report = $CPAN::META->has_inst("CPAN::Reporter");
7883         if ($can_report) {
7884             $want_report = 1;
7885         } else {
7886             $CPAN::Frontend->mywarn("CPAN::Reporter not installed, falling back to ".
7887                                     "testing without\n");
7888         }
7889     }
7890     my $ready_to_report = $want_report;
7891     if ($ready_to_report
7892         && (
7893             substr($self->id,-1,1) eq "."
7894             ||
7895             $self->author->id eq "LOCAL"
7896            )
7897        ) {
7898         $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
7899                                 "for local directories\n");
7900         $ready_to_report = 0;
7901     }
7902     if ($ready_to_report
7903         &&
7904         $self->prefs->{patches}
7905         &&
7906         @{$self->prefs->{patches}}
7907         &&
7908         $self->{patched}
7909        ) {
7910         $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
7911                                 "when the source has been patched\n");
7912         $ready_to_report = 0;
7913     }
7914     if ($want_expect) {
7915         if ($ready_to_report) {
7916             $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ".
7917                                     "not supported when distroprefs specify ".
7918                                     "an interactive test\n");
7919         }
7920         $tests_ok = $self->_run_via_expect($system,$expect_model) == 0;
7921     } elsif ( $ready_to_report ) {
7922         $tests_ok = CPAN::Reporter::test($self, $system);
7923     } else {
7924         $tests_ok = system($system) == 0;
7925     }
7926     $self->introduce_myself;
7927     if ( $tests_ok ) {
7928         {
7929             my @prereq;
7930
7931             # local $CPAN::DEBUG = 16; # Distribution
7932             for my $m (keys %{$self->{sponsored_mods}}) {
7933                 my $m_obj = CPAN::Shell->expand("Module",$m) or next;
7934                 # XXX we need available_version which reflects
7935                 # $ENV{PERL5LIB} so that already tested but not yet
7936                 # installed modules are counted.
7937                 my $available_version = $m_obj->available_version;
7938                 my $available_file = $m_obj->available_file;
7939                 if ($available_version &&
7940                     !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m})
7941                    ) {
7942                     CPAN->debug("m[$m] good enough available_version[$available_version]")
7943                         if $CPAN::DEBUG;
7944                 } elsif ($available_file
7945                          && (
7946                              !$self->{prereq_pm}{$m}
7947                              ||
7948                              $self->{prereq_pm}{$m} == 0
7949                             )
7950                         ) {
7951                     # lex Class::Accessor::Chained::Fast which has no $VERSION
7952                     CPAN->debug("m[$m] have available_file[$available_file]")
7953                         if $CPAN::DEBUG;
7954                 } else {
7955                     push @prereq, $m;
7956                 }
7957             }
7958             if (@prereq){
7959                 my $cnt = @prereq;
7960                 my $which = join ",", @prereq;
7961                 my $but = $cnt == 1 ? "one dependency not OK ($which)" :
7962                     "$cnt dependencies missing ($which)";
7963                 $CPAN::Frontend->mywarn("Tests succeeded but $but\n");
7964                 $self->{make_test} = CPAN::Distrostatus->new("NO $but");
7965                 $self->store_persistent_state;
7966                 return;
7967             }
7968         }
7969
7970         $CPAN::Frontend->myprint("  $system -- OK\n");
7971         $self->{make_test} = CPAN::Distrostatus->new("YES");
7972         $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
7973         # probably impossible to need the next line because badtestcnt
7974         # has a lifespan of one command
7975         delete $self->{badtestcnt};
7976     } else {
7977         $self->{make_test} = CPAN::Distrostatus->new("NO");
7978         $self->{badtestcnt}++;
7979         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
7980     }
7981     $self->store_persistent_state;
7982 }
7983
7984 sub _prefs_with_expect {
7985     my($self,$where) = @_;
7986     return unless my $prefs = $self->prefs;
7987     return unless my $where_prefs = $prefs->{$where};
7988     if ($where_prefs->{expect}) {
7989         return {
7990                 mode => "deterministic",
7991                 timeout => 15,
7992                 talk => $where_prefs->{expect},
7993                };
7994     } elsif ($where_prefs->{"eexpect"}) {
7995         return $where_prefs->{"eexpect"};
7996     }
7997     return;
7998 }
7999
8000 #-> sub CPAN::Distribution::clean ;
8001 sub clean {
8002     my($self) = @_;
8003     my $make = $self->{modulebuild} ? "Build" : "make";
8004     $CPAN::Frontend->myprint("Running $make clean\n");
8005     unless (exists $self->{archived}) {
8006         $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped".
8007                                 "/untarred, nothing done\n");
8008         return 1;
8009     }
8010     unless (exists $self->{build_dir}) {
8011         $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
8012         return 1;
8013     }
8014   EXCUSE: {
8015         my @e;
8016         exists $self->{make_clean} and $self->{make_clean} eq "YES" and
8017             push @e, "make clean already called once";
8018         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
8019     }
8020     chdir $self->{build_dir} or
8021         Carp::confess("Couldn't chdir to $self->{build_dir}: $!");
8022     $self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG;
8023
8024     if ($^O eq 'MacOS') {
8025         Mac::BuildTools::make_clean($self);
8026         return;
8027     }
8028
8029     my $system;
8030     if ($self->{modulebuild}) {
8031         unless (-f "Build") {
8032             my $cwd = CPAN::anycwd();
8033             $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
8034                                     " in cwd[$cwd]. Danger, Will Robinson!");
8035             $CPAN::Frontend->mysleep(5);
8036         }
8037         $system = sprintf "%s clean", $self->_build_command();
8038     } else {
8039         $system  = join " ", $self->_make_command(), "clean";
8040     }
8041     my $system_ok = system($system) == 0;
8042     $self->introduce_myself;
8043     if ( $system_ok ) {
8044       $CPAN::Frontend->myprint("  $system -- OK\n");
8045
8046       # $self->force;
8047
8048       # Jost Krieger pointed out that this "force" was wrong because
8049       # it has the effect that the next "install" on this distribution
8050       # will untar everything again. Instead we should bring the
8051       # object's state back to where it is after untarring.
8052
8053       for my $k (qw(
8054                     force_update
8055                     install
8056                     writemakefile
8057                     make
8058                     make_test
8059                    )) {
8060           delete $self->{$k};
8061       }
8062       $self->{make_clean} = CPAN::Distrostatus->new("YES");
8063
8064     } else {
8065       # Hmmm, what to do if make clean failed?
8066
8067       $self->{make_clean} = CPAN::Distrostatus->new("NO");
8068       $CPAN::Frontend->mywarn(qq{  $system -- NOT OK\n});
8069
8070       # 2006-02-27: seems silly to me to force a make now
8071       # $self->force("make"); # so that this directory won't be used again
8072
8073     }
8074     $self->store_persistent_state;
8075 }
8076
8077 #-> sub CPAN::Distribution::goto ;
8078 sub goto {
8079     my($self,$goto) = @_;
8080     $goto = $self->normalize($goto);
8081
8082     # inject into the queue
8083
8084     CPAN::Queue->delete($self->id);
8085     CPAN::Queue->jumpqueue([$goto,$self->{reqtype}]);
8086
8087     # and run where we left off
8088
8089     my($method) = (caller(1))[3];
8090     CPAN->instance("CPAN::Distribution",$goto)->$method;
8091     CPAN::Queue->delete_first($goto);
8092 }
8093
8094 #-> sub CPAN::Distribution::install ;
8095 sub install {
8096     my($self) = @_;
8097     if (my $goto = $self->prefs->{goto}) {
8098         return $self->goto($goto);
8099     }
8100     $DB::single=1;
8101     unless ($self->{badtestcnt}) {
8102         $self->test;
8103     }
8104     if ($CPAN::Signal){
8105       delete $self->{force_update};
8106       return;
8107     }
8108     my $make = $self->{modulebuild} ? "Build" : "make";
8109     $CPAN::Frontend->myprint("Running $make install\n");
8110   EXCUSE: {
8111         my @e;
8112         unless (exists $self->{make} or exists $self->{later}) {
8113             push @e,
8114                 "Make had some problems, won't install";
8115         }
8116
8117         exists $self->{make} and
8118             (
8119              UNIVERSAL::can($self->{make},"failed") ?
8120              $self->{make}->failed :
8121              $self->{make} =~ /^NO/
8122             ) and
8123                 push @e, "Make had returned bad status, install seems impossible";
8124
8125         if (exists $self->{build_dir}) {
8126         } elsif (!@e) {
8127             push @e, "Has no own directory";
8128         }
8129
8130         if (exists $self->{make_test} and
8131             (
8132              UNIVERSAL::can($self->{make_test},"failed") ?
8133              $self->{make_test}->failed :
8134              $self->{make_test} =~ /^NO/
8135             )){
8136             if ($self->{force_update}) {
8137                 $self->{make_test}->text("FAILED but failure ignored because ".
8138                                          "'force' in effect");
8139             } else {
8140                 push @e, "make test had returned bad status, ".
8141                     "won't install without force"
8142             }
8143         }
8144         if (exists $self->{install}) {
8145             if (UNIVERSAL::can($self->{install},"text") ?
8146                 $self->{install}->text eq "YES" :
8147                 $self->{install} =~ /^YES/
8148                ) {
8149                 push @e, "Already done";
8150             } else {
8151                 # comment in Todo on 2006-02-11; maybe retry?
8152                 push @e, "Already tried without success";
8153             }
8154         }
8155
8156         exists $self->{later} and length($self->{later}) and
8157             push @e, $self->{later};
8158
8159         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
8160         unless (chdir $self->{build_dir}) {
8161             push @e, "Couldn't chdir to '$self->{build_dir}': $!";
8162         }
8163         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
8164     }
8165     $self->debug("Changed directory to $self->{build_dir}")
8166         if $CPAN::DEBUG;
8167
8168     if ($^O eq 'MacOS') {
8169         Mac::BuildTools::make_install($self);
8170         return;
8171     }
8172
8173     my $system;
8174     if (my $commandline = $self->prefs->{install}{commandline}) {
8175         $system = $commandline;
8176         $ENV{PERL} = $^X;
8177     } elsif ($self->{modulebuild}) {
8178         my($mbuild_install_build_command) =
8179             exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
8180                 $CPAN::Config->{mbuild_install_build_command} ?
8181                     $CPAN::Config->{mbuild_install_build_command} :
8182                         $self->_build_command();
8183         $system = sprintf("%s install %s",
8184                           $mbuild_install_build_command,
8185                           $CPAN::Config->{mbuild_install_arg},
8186                          );
8187     } else {
8188         my($make_install_make_command) =
8189             CPAN::HandleConfig->prefs_lookup($self,
8190                                              q{make_install_make_command})
8191                   || $self->_make_command();
8192         $system = sprintf("%s install %s",
8193                           $make_install_make_command,
8194                           $CPAN::Config->{make_install_arg},
8195                          );
8196     }
8197
8198     my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 ";
8199     my $brip = CPAN::HandleConfig->prefs_lookup($self,
8200                                                 q{build_requires_install_policy});
8201     $brip ||="ask/yes";
8202     my $id = $self->id;
8203     my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command
8204     my $want_install = "yes";
8205     if ($reqtype eq "b") {
8206         if ($brip eq "no") {
8207             $want_install = "no";
8208         } elsif ($brip =~ m|^ask/(.+)|) {
8209             my $default = $1;
8210             $default = "yes" unless $default =~ /^(y|n)/i;
8211             $want_install =
8212                 CPAN::Shell::colorable_makemaker_prompt
8213                       ("$id is just needed temporarily during building or testing. ".
8214                        "Do you want to install it permanently? (Y/n)",
8215                        $default);
8216         }
8217     }
8218     unless ($want_install =~ /^y/i) {
8219         my $is_only = "is only 'build_requires'";
8220         $CPAN::Frontend->mywarn("Not installing because $is_only\n");
8221         $self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
8222         delete $self->{force_update};
8223         return;
8224     }
8225     my($pipe) = FileHandle->new("$system $stderr |");
8226     my($makeout) = "";
8227     while (<$pipe>){
8228         print $_; # intentionally NOT use Frontend->myprint because it
8229                   # looks irritating when we markup in color what we
8230                   # just pass through from an external program
8231         $makeout .= $_;
8232     }
8233     $pipe->close;
8234     my $close_ok = $? == 0;
8235     $self->introduce_myself;
8236     if ( $close_ok ) {
8237         $CPAN::Frontend->myprint("  $system -- OK\n");
8238         $CPAN::META->is_installed($self->{build_dir});
8239         $self->{install} = CPAN::Distrostatus->new("YES");
8240     } else {
8241         $self->{install} = CPAN::Distrostatus->new("NO");
8242         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
8243         my $mimc =
8244             CPAN::HandleConfig->prefs_lookup($self,
8245                                              q{make_install_make_command});
8246         if (
8247             $makeout =~ /permission/s
8248             && $> > 0
8249             && (
8250                 ! $mimc
8251                 || $mimc eq (CPAN::HandleConfig->prefs_lookup($self,
8252                                                               q{make}))
8253                )
8254            ) {
8255             $CPAN::Frontend->myprint(
8256                                      qq{----\n}.
8257                                      qq{  You may have to su }.
8258                                      qq{to root to install the package\n}.
8259                                      qq{  (Or you may want to run something like\n}.
8260                                      qq{    o conf make_install_make_command 'sudo make'\n}.
8261                                      qq{  to raise your permissions.}
8262                                     );
8263         }
8264     }
8265     delete $self->{force_update};
8266     # $DB::single = 1;
8267     $self->store_persistent_state;
8268 }
8269
8270 sub introduce_myself {
8271     my($self) = @_;
8272     $CPAN::Frontend->myprint(sprintf("  %s\n",$self->pretty_id));
8273 }
8274
8275 #-> sub CPAN::Distribution::dir ;
8276 sub dir {
8277     shift->{build_dir};
8278 }
8279
8280 #-> sub CPAN::Distribution::perldoc ;
8281 sub perldoc {
8282     my($self) = @_;
8283
8284     my($dist) = $self->id;
8285     my $package = $self->called_for;
8286
8287     $self->_display_url( $CPAN::Defaultdocs . $package );
8288 }
8289
8290 #-> sub CPAN::Distribution::_check_binary ;
8291 sub _check_binary {
8292     my ($dist,$shell,$binary) = @_;
8293     my ($pid,$out);
8294
8295     $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
8296       if $CPAN::DEBUG;
8297
8298     if ($CPAN::META->has_inst("File::Which")) {
8299         return File::Which::which($binary);
8300     } else {
8301         local *README;
8302         $pid = open README, "which $binary|"
8303             or $CPAN::Frontend->mywarn(qq{Could not fork 'which $binary': $!\n});
8304         return unless $pid;
8305         while (<README>) {
8306             $out .= $_;
8307         }
8308         close README
8309             or $CPAN::Frontend->mywarn("Could not run 'which $binary': $!\n")
8310                 and return;
8311     }
8312
8313     $CPAN::Frontend->myprint(qq{   + $out \n})
8314       if $CPAN::DEBUG && $out;
8315
8316     return $out;
8317 }
8318
8319 #-> sub CPAN::Distribution::_display_url ;
8320 sub _display_url {
8321     my($self,$url) = @_;
8322     my($res,$saved_file,$pid,$out);
8323
8324     $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
8325       if $CPAN::DEBUG;
8326
8327     # should we define it in the config instead?
8328     my $html_converter = "html2text";
8329
8330     my $web_browser = $CPAN::Config->{'lynx'} || undef;
8331     my $web_browser_out = $web_browser
8332       ? CPAN::Distribution->_check_binary($self,$web_browser)
8333         : undef;
8334
8335     if ($web_browser_out) {
8336         # web browser found, run the action
8337         my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
8338         $CPAN::Frontend->myprint(qq{system[$browser $url]})
8339           if $CPAN::DEBUG;
8340         $CPAN::Frontend->myprint(qq{
8341 Displaying URL
8342   $url
8343 with browser $browser
8344 });
8345         $CPAN::Frontend->mysleep(1);
8346         system("$browser $url");
8347         if ($saved_file) { 1 while unlink($saved_file) }
8348     } else {
8349         # web browser not found, let's try text only
8350         my $html_converter_out =
8351           CPAN::Distribution->_check_binary($self,$html_converter);
8352         $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out);
8353
8354         if ($html_converter_out ) {
8355             # html2text found, run it
8356             $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
8357             $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n})
8358                 unless defined($saved_file);
8359
8360             local *README;
8361             $pid = open README, "$html_converter $saved_file |"
8362               or $CPAN::Frontend->mydie(qq{
8363 Could not fork '$html_converter $saved_file': $!});
8364             my($fh,$filename);
8365             if ($CPAN::META->has_inst("File::Temp")) {
8366                 $fh = File::Temp->new(
8367                                       template => 'cpan_htmlconvert_XXXX',
8368                                       suffix => '.txt',
8369                                       unlink => 0,
8370                                      );
8371                 $filename = $fh->filename;
8372             } else {
8373                 $filename = "cpan_htmlconvert_$$.txt";
8374                 $fh = FileHandle->new();
8375                 open $fh, ">$filename" or die;
8376             }
8377             while (<README>) {
8378                 $fh->print($_);
8379             }
8380             close README or
8381                 $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
8382             my $tmpin = $fh->filename;
8383             $CPAN::Frontend->myprint(sprintf(qq{
8384 Run '%s %s' and
8385 saved output to %s\n},
8386                                              $html_converter,
8387                                              $saved_file,
8388                                              $tmpin,
8389                                             )) if $CPAN::DEBUG;
8390             close $fh;
8391             local *FH;
8392             open FH, $tmpin
8393                 or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
8394             my $fh_pager = FileHandle->new;
8395             local($SIG{PIPE}) = "IGNORE";
8396             my $pager = $CPAN::Config->{'pager'} || "cat";
8397             $fh_pager->open("|$pager")
8398                 or $CPAN::Frontend->mydie(qq{
8399 Could not open pager '$pager': $!});
8400             $CPAN::Frontend->myprint(qq{
8401 Displaying URL
8402   $url
8403 with pager "$pager"
8404 });
8405             $CPAN::Frontend->mysleep(1);
8406             $fh_pager->print(<FH>);
8407             $fh_pager->close;
8408         } else {
8409             # coldn't find the web browser or html converter
8410             $CPAN::Frontend->myprint(qq{
8411 You need to install lynx or $html_converter to use this feature.});
8412         }
8413     }
8414 }
8415
8416 #-> sub CPAN::Distribution::_getsave_url ;
8417 sub _getsave_url {
8418     my($dist, $shell, $url) = @_;
8419
8420     $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
8421       if $CPAN::DEBUG;
8422
8423     my($fh,$filename);
8424     if ($CPAN::META->has_inst("File::Temp")) {
8425         $fh = File::Temp->new(
8426                               template => "cpan_getsave_url_XXXX",
8427                               suffix => ".html",
8428                               unlink => 0,
8429                              );
8430         $filename = $fh->filename;
8431     } else {
8432         $fh = FileHandle->new;
8433         $filename = "cpan_getsave_url_$$.html";
8434     }
8435     my $tmpin = $filename;
8436     if ($CPAN::META->has_usable('LWP')) {
8437         $CPAN::Frontend->myprint("Fetching with LWP:
8438   $url
8439 ");
8440         my $Ua;
8441         CPAN::LWP::UserAgent->config;
8442         eval { $Ua = CPAN::LWP::UserAgent->new; };
8443         if ($@) {
8444             $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
8445             return;
8446         } else {
8447             my($var);
8448             $Ua->proxy('http', $var)
8449                 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
8450             $Ua->no_proxy($var)
8451                 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
8452         }
8453
8454         my $req = HTTP::Request->new(GET => $url);
8455         $req->header('Accept' => 'text/html');
8456         my $res = $Ua->request($req);
8457         if ($res->is_success) {
8458             $CPAN::Frontend->myprint(" + request successful.\n")
8459                 if $CPAN::DEBUG;
8460             print $fh $res->content;
8461             close $fh;
8462             $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
8463                 if $CPAN::DEBUG;
8464             return $tmpin;
8465         } else {
8466             $CPAN::Frontend->myprint(sprintf(
8467                                              "LWP failed with code[%s], message[%s]\n",
8468                                              $res->code,
8469                                              $res->message,
8470                                             ));
8471             return;
8472         }
8473     } else {
8474         $CPAN::Frontend->mywarn("  LWP not available\n");
8475         return;
8476     }
8477 }
8478
8479 # sub CPAN::Distribution::_build_command
8480 sub _build_command {
8481     my($self) = @_;
8482     if ($^O eq "MSWin32") { # special code needed at least up to
8483                             # Module::Build 0.2611 and 0.2706; a fix
8484                             # in M:B has been promised 2006-01-30
8485         my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
8486         return "$perl ./Build";
8487     }
8488     return "./Build";
8489 }
8490
8491 package CPAN::Bundle;
8492 use strict;
8493
8494 sub look {
8495     my $self = shift;
8496     $CPAN::Frontend->myprint($self->as_string);
8497 }
8498
8499 sub undelay {
8500     my $self = shift;
8501     delete $self->{later};
8502     for my $c ( $self->contains ) {
8503         my $obj = CPAN::Shell->expandany($c) or next;
8504         $obj->undelay;
8505     }
8506 }
8507
8508 # mark as dirty/clean
8509 #-> sub CPAN::Bundle::color_cmd_tmps ;
8510 sub color_cmd_tmps {
8511     my($self) = shift;
8512     my($depth) = shift || 0;
8513     my($color) = shift || 0;
8514     my($ancestors) = shift || [];
8515     # a module needs to recurse to its cpan_file, a distribution needs
8516     # to recurse into its prereq_pms, a bundle needs to recurse into its modules
8517
8518     return if exists $self->{incommandcolor}
8519         && $color==1
8520         && $self->{incommandcolor}==$color;
8521     if ($depth>=$CPAN::MAX_RECURSION){
8522         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
8523     }
8524     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
8525
8526     for my $c ( $self->contains ) {
8527         my $obj = CPAN::Shell->expandany($c) or next;
8528         CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
8529         $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
8530     }
8531     # never reached code?
8532     #if ($color==0) {
8533       #delete $self->{badtestcnt};
8534     #}
8535     $self->{incommandcolor} = $color;
8536 }
8537
8538 #-> sub CPAN::Bundle::as_string ;
8539 sub as_string {
8540     my($self) = @_;
8541     $self->contains;
8542     # following line must be "=", not "||=" because we have a moving target
8543     $self->{INST_VERSION} = $self->inst_version;
8544     return $self->SUPER::as_string;
8545 }
8546
8547 #-> sub CPAN::Bundle::contains ;
8548 sub contains {
8549     my($self) = @_;
8550     my($inst_file) = $self->inst_file || "";
8551     my($id) = $self->id;
8552     $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
8553     if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) {
8554         undef $inst_file;
8555     }
8556     unless ($inst_file) {
8557         # Try to get at it in the cpan directory
8558         $self->debug("no inst_file") if $CPAN::DEBUG;
8559         my $cpan_file;
8560         $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
8561               $cpan_file = $self->cpan_file;
8562         if ($cpan_file eq "N/A") {
8563             $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
8564   Maybe stale symlink? Maybe removed during session? Giving up.\n");
8565         }
8566         my $dist = $CPAN::META->instance('CPAN::Distribution',
8567                                          $self->cpan_file);
8568         $self->debug("before get id[$dist->{ID}]") if $CPAN::DEBUG;
8569         $dist->get;
8570         $self->debug("after get id[$dist->{ID}]") if $CPAN::DEBUG;
8571         my($todir) = $CPAN::Config->{'cpan_home'};
8572         my(@me,$from,$to,$me);
8573         @me = split /::/, $self->id;
8574         $me[-1] .= ".pm";
8575         $me = File::Spec->catfile(@me);
8576         $from = $self->find_bundle_file($dist->{build_dir},join('/',@me));
8577         $to = File::Spec->catfile($todir,$me);
8578         File::Path::mkpath(File::Basename::dirname($to));
8579         File::Copy::copy($from, $to)
8580               or Carp::confess("Couldn't copy $from to $to: $!");
8581         $inst_file = $to;
8582     }
8583     my @result;
8584     my $fh = FileHandle->new;
8585     local $/ = "\n";
8586     open($fh,$inst_file) or die "Could not open '$inst_file': $!";
8587     my $in_cont = 0;
8588     $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
8589     while (<$fh>) {
8590         $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
8591             m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
8592         next unless $in_cont;
8593         next if /^=/;
8594         s/\#.*//;
8595         next if /^\s+$/;
8596         chomp;
8597         push @result, (split " ", $_, 2)[0];
8598     }
8599     close $fh;
8600     delete $self->{STATUS};
8601     $self->{CONTAINS} = \@result;
8602     $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
8603     unless (@result) {
8604         $CPAN::Frontend->mywarn(qq{
8605 The bundle file "$inst_file" may be a broken
8606 bundlefile. It seems not to contain any bundle definition.
8607 Please check the file and if it is bogus, please delete it.
8608 Sorry for the inconvenience.
8609 });
8610     }
8611     @result;
8612 }
8613
8614 #-> sub CPAN::Bundle::find_bundle_file
8615 # $where is in local format, $what is in unix format
8616 sub find_bundle_file {
8617     my($self,$where,$what) = @_;
8618     $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
8619 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
8620 ###    my $bu = File::Spec->catfile($where,$what);
8621 ###    return $bu if -f $bu;
8622     my $manifest = File::Spec->catfile($where,"MANIFEST");
8623     unless (-f $manifest) {
8624         require ExtUtils::Manifest;
8625         my $cwd = CPAN::anycwd();
8626         $self->safe_chdir($where);
8627         ExtUtils::Manifest::mkmanifest();
8628         $self->safe_chdir($cwd);
8629     }
8630     my $fh = FileHandle->new($manifest)
8631         or Carp::croak("Couldn't open $manifest: $!");
8632     local($/) = "\n";
8633     my $bundle_filename = $what;
8634     $bundle_filename =~ s|Bundle.*/||;
8635     my $bundle_unixpath;
8636     while (<$fh>) {
8637         next if /^\s*\#/;
8638         my($file) = /(\S+)/;
8639         if ($file =~ m|\Q$what\E$|) {
8640             $bundle_unixpath = $file;
8641             # return File::Spec->catfile($where,$bundle_unixpath); # bad
8642             last;
8643         }
8644         # retry if she managed to have no Bundle directory
8645         $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
8646     }
8647     return File::Spec->catfile($where, split /\//, $bundle_unixpath)
8648         if $bundle_unixpath;
8649     Carp::croak("Couldn't find a Bundle file in $where");
8650 }
8651
8652 # needs to work quite differently from Module::inst_file because of
8653 # cpan_home/Bundle/ directory and the possibility that we have
8654 # shadowing effect. As it makes no sense to take the first in @INC for
8655 # Bundles, we parse them all for $VERSION and take the newest.
8656
8657 #-> sub CPAN::Bundle::inst_file ;
8658 sub inst_file {
8659     my($self) = @_;
8660     my($inst_file);
8661     my(@me);
8662     @me = split /::/, $self->id;
8663     $me[-1] .= ".pm";
8664     my($incdir,$bestv);
8665     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
8666         my $bfile = File::Spec->catfile($incdir, @me);
8667         CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
8668         next unless -f $bfile;
8669         my $foundv = MM->parse_version($bfile);
8670         if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
8671             $self->{INST_FILE} = $bfile;
8672             $self->{INST_VERSION} = $bestv = $foundv;
8673         }
8674     }
8675     $self->{INST_FILE};
8676 }
8677
8678 #-> sub CPAN::Bundle::inst_version ;
8679 sub inst_version {
8680     my($self) = @_;
8681     $self->inst_file; # finds INST_VERSION as side effect
8682     $self->{INST_VERSION};
8683 }
8684
8685 #-> sub CPAN::Bundle::rematein ;
8686 sub rematein {
8687     my($self,$meth) = @_;
8688     $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
8689     my($id) = $self->id;
8690     Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
8691         unless $self->inst_file || $self->cpan_file;
8692     my($s,%fail);
8693     for $s ($self->contains) {
8694         my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
8695             $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
8696         if ($type eq 'CPAN::Distribution') {
8697             $CPAN::Frontend->mywarn(qq{
8698 The Bundle }.$self->id.qq{ contains
8699 explicitly a file '$s'.
8700 Going to $meth that.
8701 });
8702             $CPAN::Frontend->mysleep(5);
8703         }
8704         # possibly noisy action:
8705         $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
8706         my $obj = $CPAN::META->instance($type,$s);
8707         $obj->{reqtype} = $self->{reqtype};
8708         $obj->$meth();
8709     }
8710 }
8711
8712 # If a bundle contains another that contains an xs_file we have here,
8713 # we just don't bother I suppose
8714 #-> sub CPAN::Bundle::xs_file
8715 sub xs_file {
8716     return 0;
8717 }
8718
8719 #-> sub CPAN::Bundle::force ;
8720 sub fforce   { shift->rematein('fforce',@_); }
8721 #-> sub CPAN::Bundle::force ;
8722 sub force   { shift->rematein('force',@_); }
8723 #-> sub CPAN::Bundle::notest ;
8724 sub notest  { shift->rematein('notest',@_); }
8725 #-> sub CPAN::Bundle::get ;
8726 sub get     { shift->rematein('get',@_); }
8727 #-> sub CPAN::Bundle::make ;
8728 sub make    { shift->rematein('make',@_); }
8729 #-> sub CPAN::Bundle::test ;
8730 sub test    {
8731     my $self = shift;
8732     # $self->{badtestcnt} ||= 0;
8733     $self->rematein('test',@_);
8734 }
8735 #-> sub CPAN::Bundle::install ;
8736 sub install {
8737   my $self = shift;
8738   $self->rematein('install',@_);
8739 }
8740 #-> sub CPAN::Bundle::clean ;
8741 sub clean   { shift->rematein('clean',@_); }
8742
8743 #-> sub CPAN::Bundle::uptodate ;
8744 sub uptodate {
8745     my($self) = @_;
8746     return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
8747     my $c;
8748     foreach $c ($self->contains) {
8749         my $obj = CPAN::Shell->expandany($c);
8750         return 0 unless $obj->uptodate;
8751     }
8752     return 1;
8753 }
8754
8755 #-> sub CPAN::Bundle::readme ;
8756 sub readme  {
8757     my($self) = @_;
8758     my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
8759 No File found for bundle } . $self->id . qq{\n}), return;
8760     $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
8761     $CPAN::META->instance('CPAN::Distribution',$file)->readme;
8762 }
8763
8764 package CPAN::Module;
8765 use strict;
8766
8767 # Accessors
8768 # sub CPAN::Module::userid
8769 sub userid {
8770     my $self = shift;
8771     my $ro = $self->ro;
8772     return unless $ro;
8773     return $ro->{userid} || $ro->{CPAN_USERID};
8774 }
8775 # sub CPAN::Module::description
8776 sub description {
8777     my $self = shift;
8778     my $ro = $self->ro or return "";
8779     $ro->{description}
8780 }
8781
8782 sub distribution {
8783     my($self) = @_;
8784     CPAN::Shell->expand("Distribution",$self->cpan_file);
8785 }
8786
8787 # sub CPAN::Module::undelay
8788 sub undelay {
8789     my $self = shift;
8790     delete $self->{later};
8791     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
8792         $dist->undelay;
8793     }
8794 }
8795
8796 # mark as dirty/clean
8797 #-> sub CPAN::Module::color_cmd_tmps ;
8798 sub color_cmd_tmps {
8799     my($self) = shift;
8800     my($depth) = shift || 0;
8801     my($color) = shift || 0;
8802     my($ancestors) = shift || [];
8803     # a module needs to recurse to its cpan_file
8804
8805     return if exists $self->{incommandcolor}
8806         && $color==1
8807         && $self->{incommandcolor}==$color;
8808     return if $color==0 && !$self->{incommandcolor};
8809     if ($color>=1) {
8810         if ( $self->uptodate ) {
8811             $self->{incommandcolor} = $color;
8812             return;
8813         } elsif (my $have_version = $self->available_version) {
8814             # maybe what we have is good enough
8815             if (@$ancestors) {
8816                 my $who_asked_for_me = $ancestors->[-1];
8817                 my $obj = CPAN::Shell->expandany($who_asked_for_me);
8818                 if (0) {
8819                 } elsif ($obj->isa("CPAN::Bundle")) {
8820                     # bundles cannot specify a minimum version
8821                     return;
8822                 } elsif ($obj->isa("CPAN::Distribution")) {
8823                     if (my $prereq_pm = $obj->prereq_pm) {
8824                         for my $k (keys %$prereq_pm) {
8825                             if (my $want_version = $prereq_pm->{$k}{$self->id}) {
8826                                 if (CPAN::Version->vcmp($have_version,$want_version) >= 0) {
8827                                     $self->{incommandcolor} = $color;
8828                                     return;
8829                                 }
8830                             }
8831                         }
8832                     }
8833                 }
8834             }
8835         }
8836     } else {
8837         $self->{incommandcolor} = $color; # set me before recursion,
8838                                           # so we can break it
8839     }
8840     if ($depth>=$CPAN::MAX_RECURSION){
8841         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
8842     }
8843     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
8844
8845     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
8846         $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
8847     }
8848     # unreached code?
8849     # if ($color==0) {
8850     #    delete $self->{badtestcnt};
8851     # }
8852     $self->{incommandcolor} = $color;
8853 }
8854
8855 #-> sub CPAN::Module::as_glimpse ;
8856 sub as_glimpse {
8857     my($self) = @_;
8858     my(@m);
8859     my $class = ref($self);
8860     $class =~ s/^CPAN:://;
8861     my $color_on = "";
8862     my $color_off = "";
8863     if (
8864         $CPAN::Shell::COLOR_REGISTERED
8865         &&
8866         $CPAN::META->has_inst("Term::ANSIColor")
8867         &&
8868         $self->description
8869        ) {
8870         $color_on = Term::ANSIColor::color("green");
8871         $color_off = Term::ANSIColor::color("reset");
8872     }
8873     my $uptodateness = " ";
8874     if ($class eq "Bundle") {
8875     } elsif ($self->uptodate) {
8876         $uptodateness = "=";
8877     } elsif ($self->inst_version) {
8878         $uptodateness = "<";
8879     }
8880     push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n",
8881                      $class,
8882                      $uptodateness,
8883                      $color_on,
8884                      $self->id,
8885                      $color_off,
8886                      ($self->distribution ?
8887                       $self->distribution->pretty_id :
8888                       $self->cpan_userid
8889                      ),
8890                     );
8891     join "", @m;
8892 }
8893
8894 #-> sub CPAN::Module::dslip_status
8895 sub dslip_status {
8896     my($self) = @_;
8897     my($stat);
8898     # development status
8899     @{$stat->{D}}{qw,i c a b R M S,}     = qw,idea
8900                                               pre-alpha alpha beta released
8901                                               mature standard,;
8902     # support level
8903     @{$stat->{S}}{qw,m d u n a,}         = qw,mailing-list
8904                                               developer comp.lang.perl.*
8905                                               none abandoned,;
8906     # language
8907     @{$stat->{L}}{qw,p c + o h,}         = qw,perl C C++ other hybrid,;
8908     # interface
8909     @{$stat->{I}}{qw,f r O p h n,}       = qw,functions
8910                                               references+ties
8911                                               object-oriented pragma
8912                                               hybrid none,;
8913     # public licence
8914     @{$stat->{P}}{qw,p g l b a o d r n,} = qw,Standard-Perl
8915                                               GPL LGPL
8916                                               BSD Artistic
8917                                               open-source
8918                                               distribution_allowed
8919                                               restricted_distribution
8920                                               no_licence,;
8921     for my $x (qw(d s l i p)) {
8922         $stat->{$x}{' '} = 'unknown';
8923         $stat->{$x}{'?'} = 'unknown';
8924     }
8925     my $ro = $self->ro;
8926     return +{} unless $ro && $ro->{statd};
8927     return {
8928             D  => $ro->{statd},
8929             S  => $ro->{stats},
8930             L  => $ro->{statl},
8931             I  => $ro->{stati},
8932             P  => $ro->{statp},
8933             DV => $stat->{D}{$ro->{statd}},
8934             SV => $stat->{S}{$ro->{stats}},
8935             LV => $stat->{L}{$ro->{statl}},
8936             IV => $stat->{I}{$ro->{stati}},
8937             PV => $stat->{P}{$ro->{statp}},
8938            };
8939 }
8940
8941 #-> sub CPAN::Module::as_string ;
8942 sub as_string {
8943     my($self) = @_;
8944     my(@m);
8945     CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
8946     my $class = ref($self);
8947     $class =~ s/^CPAN:://;
8948     local($^W) = 0;
8949     push @m, $class, " id = $self->{ID}\n";
8950     my $sprintf = "    %-12s %s\n";
8951     push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
8952         if $self->description;
8953     my $sprintf2 = "    %-12s %s (%s)\n";
8954     my($userid);
8955     $userid = $self->userid;
8956     if ( $userid ){
8957         my $author;
8958         if ($author = CPAN::Shell->expand('Author',$userid)) {
8959           my $email = "";
8960           my $m; # old perls
8961           if ($m = $author->email) {
8962             $email = " <$m>";
8963           }
8964           push @m, sprintf(
8965                            $sprintf2,
8966                            'CPAN_USERID',
8967                            $userid,
8968                            $author->fullname . $email
8969                           );
8970         }
8971     }
8972     push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
8973         if $self->cpan_version;
8974     if (my $cpan_file = $self->cpan_file){
8975         push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
8976         if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
8977             my $upload_date = $dist->upload_date;
8978             if ($upload_date) {
8979                 push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
8980             }
8981         }
8982     }
8983     my $sprintf3 = "    %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n";
8984     my $dslip = $self->dslip_status;
8985     push @m, sprintf(
8986                      $sprintf3,
8987                      'DSLIP_STATUS',
8988                      @{$dslip}{qw(D S L I P DV SV LV IV PV)},
8989                     ) if $dslip->{D};
8990     my $local_file = $self->inst_file;
8991     unless ($self->{MANPAGE}) {
8992         my $manpage;
8993         if ($local_file) {
8994             $manpage = $self->manpage_headline($local_file);
8995         } else {
8996             # If we have already untarred it, we should look there
8997             my $dist = $CPAN::META->instance('CPAN::Distribution',
8998                                              $self->cpan_file);
8999             # warn "dist[$dist]";
9000             # mff=manifest file; mfh=manifest handle
9001             my($mff,$mfh);
9002             if (
9003                 $dist->{build_dir}
9004                 and
9005                 (-f  ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
9006                 and
9007                 $mfh = FileHandle->new($mff)
9008                ) {
9009                 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
9010                 my $lfre = $self->id; # local file RE
9011                 $lfre =~ s/::/./g;
9012                 $lfre .= "\\.pm\$";
9013                 my($lfl); # local file file
9014                 local $/ = "\n";
9015                 my(@mflines) = <$mfh>;
9016                 for (@mflines) {
9017                     s/^\s+//;
9018                     s/\s.*//s;
9019                 }
9020                 while (length($lfre)>5 and !$lfl) {
9021                     ($lfl) = grep /$lfre/, @mflines;
9022                     CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
9023                     $lfre =~ s/.+?\.//;
9024                 }
9025                 $lfl =~ s/\s.*//; # remove comments
9026                 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
9027                 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
9028                 # warn "lfl_abs[$lfl_abs]";
9029                 if (-f $lfl_abs) {
9030                     $manpage = $self->manpage_headline($lfl_abs);
9031                 }
9032             }
9033         }
9034         $self->{MANPAGE} = $manpage if $manpage;
9035     }
9036     my($item);
9037     for $item (qw/MANPAGE/) {
9038         push @m, sprintf($sprintf, $item, $self->{$item})
9039             if exists $self->{$item};
9040     }
9041     for $item (qw/CONTAINS/) {
9042         push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
9043             if exists $self->{$item} && @{$self->{$item}};
9044     }
9045     push @m, sprintf($sprintf, 'INST_FILE',
9046                      $local_file || "(not installed)");
9047     push @m, sprintf($sprintf, 'INST_VERSION',
9048                      $self->inst_version) if $local_file;
9049     join "", @m, "\n";
9050 }
9051
9052 sub manpage_headline {
9053   my($self,$local_file) = @_;
9054   my(@local_file) = $local_file;
9055   $local_file =~ s/\.pm(?!\n)\Z/.pod/;
9056   push @local_file, $local_file;
9057   my(@result,$locf);
9058   for $locf (@local_file) {
9059     next unless -f $locf;
9060     my $fh = FileHandle->new($locf)
9061         or $Carp::Frontend->mydie("Couldn't open $locf: $!");
9062     my $inpod = 0;
9063     local $/ = "\n";
9064     while (<$fh>) {
9065       $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
9066           m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
9067       next unless $inpod;
9068       next if /^=/;
9069       next if /^\s+$/;
9070       chomp;
9071       push @result, $_;
9072     }
9073     close $fh;
9074     last if @result;
9075   }
9076   for (@result) {
9077       s/^\s+//;
9078       s/\s+$//;
9079   }
9080   join " ", @result;
9081 }
9082
9083 #-> sub CPAN::Module::cpan_file ;
9084 # Note: also inherited by CPAN::Bundle
9085 sub cpan_file {
9086     my $self = shift;
9087     # CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
9088     unless ($self->ro) {
9089         CPAN::Index->reload;
9090     }
9091     my $ro = $self->ro;
9092     if ($ro && defined $ro->{CPAN_FILE}){
9093         return $ro->{CPAN_FILE};
9094     } else {
9095         my $userid = $self->userid;
9096         if ( $userid ) {
9097             if ($CPAN::META->exists("CPAN::Author",$userid)) {
9098                 my $author = $CPAN::META->instance("CPAN::Author",
9099                                                    $userid);
9100                 my $fullname = $author->fullname;
9101                 my $email = $author->email;
9102                 unless (defined $fullname && defined $email) {
9103                     return sprintf("Contact Author %s",
9104                                    $userid,
9105                                   );
9106                 }
9107                 return "Contact Author $fullname <$email>";
9108             } else {
9109                 return "Contact Author $userid (Email address not available)";
9110             }
9111         } else {
9112             return "N/A";
9113         }
9114     }
9115 }
9116
9117 #-> sub CPAN::Module::cpan_version ;
9118 sub cpan_version {
9119     my $self = shift;
9120
9121     my $ro = $self->ro;
9122     unless ($ro) {
9123         # Can happen with modules that are not on CPAN
9124         $ro = {};
9125     }
9126     $ro->{CPAN_VERSION} = 'undef'
9127         unless defined $ro->{CPAN_VERSION};
9128     $ro->{CPAN_VERSION};
9129 }
9130
9131 #-> sub CPAN::Module::force ;
9132 sub force {
9133     my($self) = @_;
9134     $self->{force_update} = 1;
9135 }
9136
9137 #-> sub CPAN::Module::fforce ;
9138 sub fforce {
9139     my($self) = @_;
9140     $self->{force_update} = 2;
9141 }
9142
9143 sub notest {
9144     my($self) = @_;
9145     # warn "XDEBUG: set notest for Module";
9146     $self->{'notest'}++;
9147 }
9148
9149 #-> sub CPAN::Module::rematein ;
9150 sub rematein {
9151     my($self,$meth) = @_;
9152     $CPAN::Frontend->myprint(sprintf("Running %s for module '%s'\n",
9153                                      $meth,
9154                                      $self->id));
9155     my $cpan_file = $self->cpan_file;
9156     if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
9157       $CPAN::Frontend->mywarn(sprintf qq{
9158   The module %s isn\'t available on CPAN.
9159
9160   Either the module has not yet been uploaded to CPAN, or it is
9161   temporary unavailable. Please contact the author to find out
9162   more about the status. Try 'i %s'.
9163 },
9164                               $self->id,
9165                               $self->id,
9166                              );
9167       return;
9168     }
9169     my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
9170     $pack->called_for($self->id);
9171     if (exists $self->{force_update}){
9172         if ($self->{force_update} == 2) {
9173             $pack->fforce($meth);
9174         } else {
9175             $pack->force($meth);
9176         }
9177     }
9178     $pack->notest($meth) if exists $self->{'notest'};
9179
9180     $pack->{reqtype} ||= "";
9181     CPAN->debug("dist-reqtype[$pack->{reqtype}]".
9182                 "self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG;
9183         if ($pack->{reqtype}) {
9184             if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) {
9185                 $pack->{reqtype} = $self->{reqtype};
9186                 if (
9187                     exists $pack->{install}
9188                     &&
9189                     (
9190                      UNIVERSAL::can($pack->{install},"failed") ?
9191                      $pack->{install}->failed :
9192                      $pack->{install} =~ /^NO/
9193                     )
9194                    ) {
9195                     delete $pack->{install};
9196                     $CPAN::Frontend->mywarn
9197                         ("Promoting $pack->{ID} from 'build_requires' to 'requires'");
9198                 }
9199             }
9200         } else {
9201             $pack->{reqtype} = $self->{reqtype};
9202         }
9203
9204     eval {
9205         $pack->$meth();
9206     };
9207     my $err = $@;
9208     $pack->unforce if $pack->can("unforce") && exists $self->{force_update};
9209     $pack->unnotest if $pack->can("unnotest") && exists $self->{'notest'};
9210     delete $self->{force_update};
9211     delete $self->{'notest'};
9212     if ($err) {
9213         die $err;
9214     }
9215 }
9216
9217 #-> sub CPAN::Module::perldoc ;
9218 sub perldoc { shift->rematein('perldoc') }
9219 #-> sub CPAN::Module::readme ;
9220 sub readme  { shift->rematein('readme') }
9221 #-> sub CPAN::Module::look ;
9222 sub look    { shift->rematein('look') }
9223 #-> sub CPAN::Module::cvs_import ;
9224 sub cvs_import { shift->rematein('cvs_import') }
9225 #-> sub CPAN::Module::get ;
9226 sub get     { shift->rematein('get',@_) }
9227 #-> sub CPAN::Module::make ;
9228 sub make    { shift->rematein('make') }
9229 #-> sub CPAN::Module::test ;
9230 sub test   {
9231     my $self = shift;
9232     # $self->{badtestcnt} ||= 0;
9233     $self->rematein('test',@_);
9234 }
9235 #-> sub CPAN::Module::uptodate ;
9236 sub uptodate {
9237     my($self) = @_;
9238     local($_); # protect against a bug in MakeMaker 6.17
9239     my($latest) = $self->cpan_version;
9240     $latest ||= 0;
9241     my($inst_file) = $self->inst_file;
9242     my($have) = 0;
9243     if (defined $inst_file) {
9244         $have = $self->inst_version;
9245     }
9246     local($^W)=0;
9247     if ($inst_file
9248         &&
9249         ! CPAN::Version->vgt($latest, $have)
9250        ) {
9251         CPAN->debug("returning uptodate. inst_file[$inst_file] ".
9252                     "latest[$latest] have[$have]") if $CPAN::DEBUG;
9253         return 1;
9254     }
9255     return;
9256 }
9257 #-> sub CPAN::Module::install ;
9258 sub install {
9259     my($self) = @_;
9260     my($doit) = 0;
9261     if ($self->uptodate
9262         &&
9263         not exists $self->{force_update}
9264        ) {
9265         $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
9266                                          $self->id,
9267                                          $self->inst_version,
9268                                         ));
9269     } else {
9270         $doit = 1;
9271     }
9272     my $ro = $self->ro;
9273     if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
9274         $CPAN::Frontend->mywarn(qq{
9275 \n\n\n     ***WARNING***
9276      The module $self->{ID} has no active maintainer.\n\n\n
9277 });
9278         $CPAN::Frontend->mysleep(5);
9279     }
9280     $self->rematein('install') if $doit;
9281 }
9282 #-> sub CPAN::Module::clean ;
9283 sub clean  { shift->rematein('clean') }
9284
9285 #-> sub CPAN::Module::inst_file ;
9286 sub inst_file {
9287     my($self) = @_;
9288     $self->_file_in_path([@INC]);
9289 }
9290
9291 #-> sub CPAN::Module::available_file ;
9292 sub available_file {
9293     my($self) = @_;
9294     my $sep = $Config::Config{path_sep};
9295     my $perllib = $ENV{PERL5LIB};
9296     $perllib = $ENV{PERLLIB} unless defined $perllib;
9297     my @perllib = split(/$sep/,$perllib) if defined $perllib;
9298     $self->_file_in_path([@perllib,@INC]);
9299 }
9300
9301 #-> sub CPAN::Module::file_in_path ;
9302 sub _file_in_path {
9303     my($self,$path) = @_;
9304     my($dir,@packpath);
9305     @packpath = split /::/, $self->{ID};
9306     $packpath[-1] .= ".pm";
9307     if (@packpath == 1 && $packpath[0] eq "readline.pm") {
9308         unshift @packpath, "Term", "ReadLine"; # historical reasons
9309     }
9310     foreach $dir (@$path) {
9311         my $pmfile = File::Spec->catfile($dir,@packpath);
9312         if (-f $pmfile){
9313             return $pmfile;
9314         }
9315     }
9316     return;
9317 }
9318
9319 #-> sub CPAN::Module::xs_file ;
9320 sub xs_file {
9321     my($self) = @_;
9322     my($dir,@packpath);
9323     @packpath = split /::/, $self->{ID};
9324     push @packpath, $packpath[-1];
9325     $packpath[-1] .= "." . $Config::Config{'dlext'};
9326     foreach $dir (@INC) {
9327         my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
9328         if (-f $xsfile){
9329             return $xsfile;
9330         }
9331     }
9332     return;
9333 }
9334
9335 #-> sub CPAN::Module::inst_version ;
9336 sub inst_version {
9337     my($self) = @_;
9338     my $parsefile = $self->inst_file or return;
9339     my $have = $self->parse_version($parsefile);
9340     $have;
9341 }
9342
9343 #-> sub CPAN::Module::inst_version ;
9344 sub available_version {
9345     my($self) = @_;
9346     my $parsefile = $self->available_file or return;
9347     my $have = $self->parse_version($parsefile);
9348     $have;
9349 }
9350
9351 #-> sub CPAN::Module::parse_version ;
9352 sub parse_version {
9353     my($self,$parsefile) = @_;
9354     my $have = MM->parse_version($parsefile);
9355     $have = "undef" unless defined $have && length $have;
9356     $have =~ s/^ //; # since the %vd hack these two lines here are needed
9357     $have =~ s/ $//; # trailing whitespace happens all the time
9358
9359     $have = CPAN::Version->readable($have);
9360
9361     $have =~ s/\s*//g; # stringify to float around floating point issues
9362     $have; # no stringify needed, \s* above matches always
9363 }
9364
9365 package CPAN;
9366 use strict;
9367
9368 1;
9369
9370
9371 __END__
9372
9373 =head1 NAME
9374
9375 CPAN - query, download and build perl modules from CPAN sites
9376
9377 =head1 SYNOPSIS
9378
9379 Interactive mode:
9380
9381   perl -MCPAN -e shell
9382
9383 --or--
9384
9385   cpan
9386
9387 Basic commands:
9388
9389   # Modules:
9390
9391   cpan> install Acme::Meta                       # in the shell
9392
9393   CPAN::Shell->install("Acme::Meta");            # in perl
9394
9395   # Distributions:
9396
9397   cpan> install NWCLARK/Acme-Meta-0.02.tar.gz    # in the shell
9398
9399   CPAN::Shell->
9400     install("NWCLARK/Acme-Meta-0.02.tar.gz");    # in perl
9401
9402   # module objects:
9403
9404   $mo = CPAN::Shell->expandany($mod);
9405   $mo = CPAN::Shell->expand("Module",$mod);      # same thing
9406
9407   # distribution objects:
9408
9409   $do = CPAN::Shell->expand("Module",$mod)->distribution;
9410   $do = CPAN::Shell->expandany($distro);         # same thing
9411   $do = CPAN::Shell->expand("Distribution",
9412                             $distro);            # same thing
9413
9414 =head1 DESCRIPTION
9415
9416 The CPAN module automates or at least simplifies the make and install
9417 of perl modules and extensions. It includes some primitive searching
9418 capabilities and knows how to use Net::FTP or LWP or some external
9419 download clients to fetch the distributions from the net.
9420
9421 These are fetched from one or more of the mirrored CPAN (Comprehensive
9422 Perl Archive Network) sites and unpacked in a dedicated directory.
9423
9424 The CPAN module also supports the concept of named and versioned
9425 I<bundles> of modules. Bundles simplify the handling of sets of
9426 related modules. See Bundles below.
9427
9428 The package contains a session manager and a cache manager. The
9429 session manager keeps track of what has been fetched, built and
9430 installed in the current session. The cache manager keeps track of the
9431 disk space occupied by the make processes and deletes excess space
9432 according to a simple FIFO mechanism.
9433
9434 All methods provided are accessible in a programmer style and in an
9435 interactive shell style.
9436
9437 =head2 CPAN::shell([$prompt, $command]) Starting Interactive Mode
9438
9439 The interactive mode is entered by running
9440
9441     perl -MCPAN -e shell
9442
9443 or
9444
9445     cpan
9446
9447 which puts you into a readline interface. If C<Term::ReadKey> and
9448 either C<Term::ReadLine::Perl> or C<Term::ReadLine::Gnu> are installed
9449 it supports both history and command completion.
9450
9451 Once you are on the command line, type C<h> to get a one page help
9452 screen and the rest should be self-explanatory.
9453
9454 The function call C<shell> takes two optional arguments, one is the
9455 prompt, the second is the default initial command line (the latter
9456 only works if a real ReadLine interface module is installed).
9457
9458 The most common uses of the interactive modes are
9459
9460 =over 2
9461
9462 =item Searching for authors, bundles, distribution files and modules
9463
9464 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
9465 for each of the four categories and another, C<i> for any of the
9466 mentioned four. Each of the four entities is implemented as a class
9467 with slightly differing methods for displaying an object.
9468
9469 Arguments you pass to these commands are either strings exactly matching
9470 the identification string of an object or regular expressions that are
9471 then matched case-insensitively against various attributes of the
9472 objects. The parser recognizes a regular expression only if you
9473 enclose it between two slashes.
9474
9475 The principle is that the number of found objects influences how an
9476 item is displayed. If the search finds one item, the result is
9477 displayed with the rather verbose method C<as_string>, but if we find
9478 more than one, we display each object with the terse method
9479 C<as_glimpse>.
9480
9481 =item C<get>, C<make>, C<test>, C<install>, C<clean> modules or distributions
9482
9483 These commands take any number of arguments and investigate what is
9484 necessary to perform the action. If the argument is a distribution
9485 file name (recognized by embedded slashes), it is processed. If it is
9486 a module, CPAN determines the distribution file in which this module
9487 is included and processes that, following any dependencies named in
9488 the module's META.yml or Makefile.PL (this behavior is controlled by
9489 the configuration parameter C<prerequisites_policy>.)
9490
9491 C<get> downloads a distribution file and untars or unzips it, C<make>
9492 builds it, C<test> runs the test suite, and C<install> installs it.
9493
9494 Any C<make> or C<test> are run unconditionally. An
9495
9496   install <distribution_file>
9497
9498 also is run unconditionally. But for
9499
9500   install <module>
9501
9502 CPAN checks if an install is actually needed for it and prints
9503 I<module up to date> in the case that the distribution file containing
9504 the module doesn't need to be updated.
9505
9506 CPAN also keeps track of what it has done within the current session
9507 and doesn't try to build a package a second time regardless if it
9508 succeeded or not. It does not repeat a test run if the test
9509 has been run successfully before. Same for install runs.
9510
9511 The C<force> pragma may precede another command (currently: C<get>,
9512 C<make>, C<test>, or C<install>) and executes the command from scratch
9513 and tries to continue in case of some errors. See the section below on
9514 the C<force> and the C<fforce> pragma.
9515
9516 The C<notest> pragma may be used to skip the test part in the build
9517 process.
9518
9519 Example:
9520
9521     cpan> notest install Tk
9522
9523 A C<clean> command results in a
9524
9525   make clean
9526
9527 being executed within the distribution file's working directory.
9528
9529 =item C<readme>, C<perldoc>, C<look> module or distribution
9530
9531 C<readme> displays the README file of the associated distribution.
9532 C<Look> gets and untars (if not yet done) the distribution file,
9533 changes to the appropriate directory and opens a subshell process in
9534 that directory. C<perldoc> displays the pod documentation of the
9535 module in html or plain text format.
9536
9537 =item C<ls> author
9538
9539 =item C<ls> globbing_expression
9540
9541 The first form lists all distribution files in and below an author's
9542 CPAN directory as they are stored in the CHECKUMS files distributed on
9543 CPAN. The listing goes recursive into all subdirectories.
9544
9545 The second form allows to limit or expand the output with shell
9546 globbing as in the following examples:
9547
9548           ls JV/make*
9549           ls GSAR/*make*
9550           ls */*make*
9551
9552 The last example is very slow and outputs extra progress indicators
9553 that break the alignment of the result.
9554
9555 Note that globbing only lists directories explicitly asked for, for
9556 example FOO/* will not list FOO/bar/Acme-Sthg-n.nn.tar.gz. This may be
9557 regarded as a bug and may be changed in future versions.
9558
9559 =item C<failed>
9560
9561 The C<failed> command reports all distributions that failed on one of
9562 C<make>, C<test> or C<install> for some reason in the currently
9563 running shell session.
9564
9565 =item Persistence between sessions
9566
9567 If the C<YAML> or the c<YAML::Syck> module is installed a record of
9568 the internal state of all modules is written to disk after each step.
9569 The files contain a signature of the currently running perl version
9570 for later perusal.
9571
9572 If the configurations variable C<build_dir_reuse> is set to a true
9573 value, then CPAN.pm reads the collected YAML files. If the stored
9574 signature matches the currently running perl the stored state is
9575 loaded into memory such that effectively persistence between sessions
9576 is established.
9577
9578 =item The C<force> and the C<fforce> pragma
9579
9580 To speed things up in complex installation scenarios, CPAN.pm keeps
9581 track of what it has already done and refuses to do some things a
9582 second time. A C<get>, a C<make>, and an C<install> are not repeated.
9583 A C<test> is only repeated if the previous test was unsuccessful. The
9584 diagnostic message when CPAN.pm refuses to do something a second time
9585 is one of I<Has already been >C<unwrapped|made|tested successfully> or
9586 something similar. Another situation where CPAN refuses to act is an
9587 C<install> if the according C<test> was not successful.
9588
9589 In all these cases, the user can override the goatish behaviour by
9590 prepending the command with the word force, for example:
9591
9592   cpan> force get Foo
9593   cpan> force make AUTHOR/Bar-3.14.tar.gz
9594   cpan> force test Baz
9595   cpan> force install Acme::Meta
9596
9597 Each I<forced> command is executed with the according part of its
9598 memory erased.
9599
9600 The C<fforce> pragma is a variant that emulates a C<force get> which
9601 erases the entire memory followed by the action specified, effectively
9602 restarting the whole get/make/test/install procedure from scratch.
9603
9604 =item Lockfile
9605
9606 Interactive sessions maintain a lockfile, per default C<~/.cpan/.lock>.
9607 Batch jobs can run without a lockfile and do not disturb each other.
9608
9609 The shell offers to run in I<degraded mode> when another process is
9610 holding the lockfile. This is an experimental feature that is not yet
9611 tested very well. This second shell then does not write the history
9612 file, does not use the metadata file and has a different prompt.
9613
9614 =item Signals
9615
9616 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
9617 in the cpan-shell it is intended that you can press C<^C> anytime and
9618 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
9619 to clean up and leave the shell loop. You can emulate the effect of a
9620 SIGTERM by sending two consecutive SIGINTs, which usually means by
9621 pressing C<^C> twice.
9622
9623 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
9624 SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl
9625 Build.PL> subprocess.
9626
9627 =back
9628
9629 =head2 CPAN::Shell
9630
9631 The commands that are available in the shell interface are methods in
9632 the package CPAN::Shell. If you enter the shell command, all your
9633 input is split by the Text::ParseWords::shellwords() routine which
9634 acts like most shells do. The first word is being interpreted as the
9635 method to be called and the rest of the words are treated as arguments
9636 to this method. Continuation lines are supported if a line ends with a
9637 literal backslash.
9638
9639 =head2 autobundle
9640
9641 C<autobundle> writes a bundle file into the
9642 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
9643 a list of all modules that are both available from CPAN and currently
9644 installed within @INC. The name of the bundle file is based on the
9645 current date and a counter.
9646
9647 =head2 hosts
9648
9649 Note: this feature is still in alpha state and may change in future
9650 versions of CPAN.pm
9651
9652 This commands provides a statistical overview over recent download
9653 activities. The data for this is collected in the YAML file
9654 C<FTPstats.yml> in your C<cpan_home> directory. If no YAML module is
9655 configured or YAML not installed, then no stats are provided.
9656
9657 =head2 mkmyconfig
9658
9659 mkmyconfig() writes your own CPAN::MyConfig file into your ~/.cpan/
9660 directory so that you can save your own preferences instead of the
9661 system wide ones.
9662
9663 =head2 recompile
9664
9665 recompile() is a very special command in that it takes no argument and
9666 runs the make/test/install cycle with brute force over all installed
9667 dynamically loadable extensions (aka XS modules) with 'force' in
9668 effect. The primary purpose of this command is to finish a network
9669 installation. Imagine, you have a common source tree for two different
9670 architectures. You decide to do a completely independent fresh
9671 installation. You start on one architecture with the help of a Bundle
9672 file produced earlier. CPAN installs the whole Bundle for you, but
9673 when you try to repeat the job on the second architecture, CPAN
9674 responds with a C<"Foo up to date"> message for all modules. So you
9675 invoke CPAN's recompile on the second architecture and you're done.
9676
9677 Another popular use for C<recompile> is to act as a rescue in case your
9678 perl breaks binary compatibility. If one of the modules that CPAN uses
9679 is in turn depending on binary compatibility (so you cannot run CPAN
9680 commands), then you should try the CPAN::Nox module for recovery.
9681
9682 =head2 report Bundle|Distribution|Module
9683
9684 The C<report> command temporarily turns on the C<test_report> config
9685 variable, then runs the C<force test> command with the given
9686 arguments. The C<force> pragma is used to re-run the tests and repeat
9687 every step that might have failed before.
9688
9689 =head2 upgrade [Module|/Regex/]...
9690
9691 The C<upgrade> command first runs an C<r> command with the given
9692 arguments and then installs the newest versions of all modules that
9693 were listed by that.
9694
9695 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
9696
9697 Although it may be considered internal, the class hierarchy does matter
9698 for both users and programmer. CPAN.pm deals with above mentioned four
9699 classes, and all those classes share a set of methods. A classical
9700 single polymorphism is in effect. A metaclass object registers all
9701 objects of all kinds and indexes them with a string. The strings
9702 referencing objects have a separated namespace (well, not completely
9703 separated):
9704
9705          Namespace                         Class
9706
9707    words containing a "/" (slash)      Distribution
9708     words starting with Bundle::          Bundle
9709           everything else            Module or Author
9710
9711 Modules know their associated Distribution objects. They always refer
9712 to the most recent official release. Developers may mark their releases
9713 as unstable development versions (by inserting an underbar into the
9714 module version number which will also be reflected in the distribution
9715 name when you run 'make dist'), so the really hottest and newest
9716 distribution is not always the default.  If a module Foo circulates
9717 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
9718 way to install version 1.23 by saying
9719
9720     install Foo
9721
9722 This would install the complete distribution file (say
9723 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
9724 like to install version 1.23_90, you need to know where the
9725 distribution file resides on CPAN relative to the authors/id/
9726 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
9727 so you would have to say
9728
9729     install BAR/Foo-1.23_90.tar.gz
9730
9731 The first example will be driven by an object of the class
9732 CPAN::Module, the second by an object of class CPAN::Distribution.
9733
9734 =head2 Integrating local directories
9735
9736 Note: this feature is still in alpha state and may change in future
9737 versions of CPAN.pm
9738
9739 Distribution objects are normally distributions from the CPAN, but
9740 there is a slightly degenerate case for Distribution objects, too, of
9741 projects held on the local disk. These distribution objects have the
9742 same name as the local directory and end with a dot. A dot by itself
9743 is also allowed for the current directory at the time CPAN.pm was
9744 used. All actions such as C<make>, C<test>, and C<install> are applied
9745 directly to that directory. This gives the command C<cpan .> an
9746 interesting touch: while the normal mantra of installing a CPAN module
9747 without CPAN.pm is one of
9748
9749     perl Makefile.PL                 perl Build.PL
9750            ( go and get prerequisites )
9751     make                             ./Build
9752     make test                        ./Build test
9753     make install                     ./Build install
9754
9755 the command C<cpan .> does all of this at once. It figures out which
9756 of the two mantras is appropriate, fetches and installs all
9757 prerequisites, cares for them recursively and finally finishes the
9758 installation of the module in the current directory, be it a CPAN
9759 module or not.
9760
9761 The typical usage case is for private modules or working copies of
9762 projects from remote repositories on the local disk.
9763
9764 =head1 CONFIGURATION
9765
9766 When the CPAN module is used for the first time, a configuration
9767 dialog tries to determine a couple of site specific options. The
9768 result of the dialog is stored in a hash reference C< $CPAN::Config >
9769 in a file CPAN/Config.pm.
9770
9771 The default values defined in the CPAN/Config.pm file can be
9772 overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
9773 best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
9774 added to the search path of the CPAN module before the use() or
9775 require() statements. The mkmyconfig command writes this file for you.
9776
9777 The C<o conf> command has various bells and whistles:
9778
9779 =over
9780
9781 =item completion support
9782
9783 If you have a ReadLine module installed, you can hit TAB at any point
9784 of the commandline and C<o conf> will offer you completion for the
9785 built-in subcommands and/or config variable names.
9786
9787 =item displaying some help: o conf help
9788
9789 Displays a short help
9790
9791 =item displaying current values: o conf [KEY]
9792
9793 Displays the current value(s) for this config variable. Without KEY
9794 displays all subcommands and config variables.
9795
9796 Example:
9797
9798   o conf shell
9799
9800 =item changing of scalar values: o conf KEY VALUE
9801
9802 Sets the config variable KEY to VALUE. The empty string can be
9803 specified as usual in shells, with C<''> or C<"">
9804
9805 Example:
9806
9807   o conf wget /usr/bin/wget
9808
9809 =item changing of list values: o conf KEY SHIFT|UNSHIFT|PUSH|POP|SPLICE|LIST
9810
9811 If a config variable name ends with C<list>, it is a list. C<o conf
9812 KEY shift> removes the first element of the list, C<o conf KEY pop>
9813 removes the last element of the list. C<o conf KEYS unshift LIST>
9814 prepends a list of values to the list, C<o conf KEYS push LIST>
9815 appends a list of valued to the list.
9816
9817 Likewise, C<o conf KEY splice LIST> passes the LIST to the according
9818 splice command.
9819
9820 Finally, any other list of arguments is taken as a new list value for
9821 the KEY variable discarding the previous value.
9822
9823 Examples:
9824
9825   o conf urllist unshift http://cpan.dev.local/CPAN
9826   o conf urllist splice 3 1
9827   o conf urllist http://cpan1.local http://cpan2.local ftp://ftp.perl.org
9828
9829 =item reverting to saved: o conf defaults
9830
9831 Reverts all config variables to the state in the saved config file.
9832
9833 =item saving the config: o conf commit
9834
9835 Saves all config variables to the current config file (CPAN/Config.pm
9836 or CPAN/MyConfig.pm that was loaded at start).
9837
9838 =back
9839
9840 The configuration dialog can be started any time later again by
9841 issuing the command C< o conf init > in the CPAN shell. A subset of
9842 the configuration dialog can be run by issuing C<o conf init WORD>
9843 where WORD is any valid config variable or a regular expression.
9844
9845 =head2 Config Variables
9846
9847 Currently the following keys in the hash reference $CPAN::Config are
9848 defined:
9849
9850   applypatch         path to external prg
9851   auto_commit        commit all changes to config variables to disk
9852   build_cache        size of cache for directories to build modules
9853   build_dir          locally accessible directory to build modules
9854   build_dir_reuse    boolean if distros in build_dir are persistent
9855   build_requires_install_policy
9856                      to install or not to install when a module is
9857                      only needed for building. yes|no|ask/yes|ask/no
9858   bzip2              path to external prg
9859   cache_metadata     use serializer to cache metadata
9860   commands_quote     prefered character to use for quoting external
9861                      commands when running them. Defaults to double
9862                      quote on Windows, single tick everywhere else;
9863                      can be set to space to disable quoting
9864   check_sigs         if signatures should be verified
9865   colorize_debug     Term::ANSIColor attributes for debugging output
9866   colorize_output    boolean if Term::ANSIColor should colorize output
9867   colorize_print     Term::ANSIColor attributes for normal output
9868   colorize_warn      Term::ANSIColor attributes for warnings
9869   commandnumber_in_prompt
9870                      boolean if you want to see current command number
9871   cpan_home          local directory reserved for this package
9872   curl               path to external prg
9873   dontload_hash      DEPRECATED
9874   dontload_list      arrayref: modules in the list will not be
9875                      loaded by the CPAN::has_inst() routine
9876   ftp                path to external prg
9877   ftp_passive        if set, the envariable FTP_PASSIVE is set for downloads
9878   ftp_proxy          proxy host for ftp requests
9879   getcwd             see below
9880   gpg                path to external prg
9881   gzip               location of external program gzip
9882   histfile           file to maintain history between sessions
9883   histsize           maximum number of lines to keep in histfile
9884   http_proxy         proxy host for http requests
9885   inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
9886                      after this many seconds inactivity. Set to 0 to
9887                      never break.
9888   index_expire       after this many days refetch index files
9889   inhibit_startup_message
9890                      if true, does not print the startup message
9891   keep_source_where  directory in which to keep the source (if we do)
9892   lynx               path to external prg
9893   make               location of external make program
9894   make_arg           arguments that should always be passed to 'make'
9895   make_install_make_command
9896                      the make command for running 'make install', for
9897                      example 'sudo make'
9898   make_install_arg   same as make_arg for 'make install'
9899   makepl_arg         arguments passed to 'perl Makefile.PL'
9900   mbuild_arg         arguments passed to './Build'
9901   mbuild_install_arg arguments passed to './Build install'
9902   mbuild_install_build_command
9903                      command to use instead of './Build' when we are
9904                      in the install stage, for example 'sudo ./Build'
9905   mbuildpl_arg       arguments passed to 'perl Build.PL'
9906   ncftp              path to external prg
9907   ncftpget           path to external prg
9908   no_proxy           don't proxy to these hosts/domains (comma separated list)
9909   pager              location of external program more (or any pager)
9910   password           your password if you CPAN server wants one
9911   patch              path to external prg
9912   prefer_installer   legal values are MB and EUMM: if a module comes
9913                      with both a Makefile.PL and a Build.PL, use the
9914                      former (EUMM) or the latter (MB); if the module
9915                      comes with only one of the two, that one will be
9916                      used in any case
9917   prerequisites_policy
9918                      what to do if you are missing module prerequisites
9919                      ('follow' automatically, 'ask' me, or 'ignore')
9920   prefs_dir          local directory to store per-distro build options
9921   proxy_user         username for accessing an authenticating proxy
9922   proxy_pass         password for accessing an authenticating proxy
9923   randomize_urllist  add some randomness to the sequence of the urllist
9924   scan_cache         controls scanning of cache ('atstart' or 'never')
9925   shell              your favorite shell
9926   show_upload_date   boolean if commands should try to determine upload date
9927   tar                location of external program tar
9928   term_is_latin      if true internal UTF-8 is translated to ISO-8859-1
9929                      (and nonsense for characters outside latin range)
9930   term_ornaments     boolean to turn ReadLine ornamenting on/off
9931   test_report        email test reports (if CPAN::Reporter is installed)
9932   unzip              location of external program unzip
9933   urllist            arrayref to nearby CPAN sites (or equivalent locations)
9934   use_sqlite         use CPAN::SQLite for metadata storage (fast and lean)
9935   username           your username if you CPAN server wants one
9936   wait_list          arrayref to a wait server to try (See CPAN::WAIT)
9937   wget               path to external prg
9938   yaml_module        which module to use to read/write YAML files
9939
9940 You can set and query each of these options interactively in the cpan
9941 shell with the C<o conf> or the C<o conf init> command as specified below.
9942
9943 =over 2
9944
9945 =item C<o conf E<lt>scalar optionE<gt>>
9946
9947 prints the current value of the I<scalar option>
9948
9949 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
9950
9951 Sets the value of the I<scalar option> to I<value>
9952
9953 =item C<o conf E<lt>list optionE<gt>>
9954
9955 prints the current value of the I<list option> in MakeMaker's
9956 neatvalue format.
9957
9958 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
9959
9960 shifts or pops the array in the I<list option> variable
9961
9962 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
9963
9964 works like the corresponding perl commands.
9965
9966 =item interactive editing: o conf init [MATCH|LIST]
9967
9968 Runs an interactive configuration dialog for matching variables.
9969 Without argument runs the dialog over all supported config variables.
9970 To specify a MATCH the argument must be enclosed by slashes.
9971
9972 Examples:
9973
9974   o conf init ftp_passive ftp_proxy
9975   o conf init /color/
9976
9977 Note: this method of setting config variables often provides more
9978 explanation about the functioning of a variable than the manpage.
9979
9980 =back
9981
9982 =head2 CPAN::anycwd($path): Note on config variable getcwd
9983
9984 CPAN.pm changes the current working directory often and needs to
9985 determine its own current working directory. Per default it uses
9986 Cwd::cwd but if this doesn't work on your system for some reason,
9987 alternatives can be configured according to the following table:
9988
9989 =over 4
9990
9991 =item cwd
9992
9993 Calls Cwd::cwd
9994
9995 =item getcwd
9996
9997 Calls Cwd::getcwd
9998
9999 =item fastcwd
10000
10001 Calls Cwd::fastcwd
10002
10003 =item backtickcwd
10004
10005 Calls the external command cwd.
10006
10007 =back
10008
10009 =head2 Note on the format of the urllist parameter
10010
10011 urllist parameters are URLs according to RFC 1738. We do a little
10012 guessing if your URL is not compliant, but if you have problems with
10013 C<file> URLs, please try the correct format. Either:
10014
10015     file://localhost/whatever/ftp/pub/CPAN/
10016
10017 or
10018
10019     file:///home/ftp/pub/CPAN/
10020
10021 =head2 The urllist parameter has CD-ROM support
10022
10023 The C<urllist> parameter of the configuration table contains a list of
10024 URLs that are to be used for downloading. If the list contains any
10025 C<file> URLs, CPAN always tries to get files from there first. This
10026 feature is disabled for index files. So the recommendation for the
10027 owner of a CD-ROM with CPAN contents is: include your local, possibly
10028 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
10029
10030   o conf urllist push file://localhost/CDROM/CPAN
10031
10032 CPAN.pm will then fetch the index files from one of the CPAN sites
10033 that come at the beginning of urllist. It will later check for each
10034 module if there is a local copy of the most recent version.
10035
10036 Another peculiarity of urllist is that the site that we could
10037 successfully fetch the last file from automatically gets a preference
10038 token and is tried as the first site for the next request. So if you
10039 add a new site at runtime it may happen that the previously preferred
10040 site will be tried another time. This means that if you want to disallow
10041 a site for the next transfer, it must be explicitly removed from
10042 urllist.
10043
10044 =head2 Maintaining the urllist parameter
10045
10046 If you have YAML.pm (or some other YAML module configured in
10047 C<yaml_module>) installed, CPAN.pm collects a few statistical data
10048 about recent downloads. You can view the statistics with the C<hosts>
10049 command or inspect them directly by looking into the C<FTPstats.yml>
10050 file in your C<cpan_home> directory.
10051
10052 To get some interesting statistics it is recommended to set the
10053 C<randomize_urllist> parameter that introduces some amount of
10054 randomness into the URL selection.
10055
10056 =head2 The C<requires> and C<build_requires> dependency declarations
10057
10058 Since CPAN.pm version 1.88_51 modules declared as C<build_requires> by
10059 a distribution are treated differently depending on the config
10060 variable C<build_requires_install_policy>. By setting
10061 C<build_requires_install_policy> to C<no> such a module is not being
10062 installed. It is only built and tested and then kept in the list of
10063 tested but uninstalled modules. As such it is available during the
10064 build of the dependent module by integrating the path to the
10065 C<blib/arch> and C<blib/lib> directories in the environment variable
10066 PERL5LIB. If C<build_requires_install_policy> is set ti C<yes>, then
10067 both modules declared as C<requires> and those declared as
10068 C<build_requires> are treated alike. By setting to C<ask/yes> or
10069 C<ask/no>, CPAN.pm asks the user and sets the default accordingly.
10070
10071 =head2 Configuration for individual distributions (I<Distroprefs>)
10072
10073 (B<Note:> This feature has been introduced in CPAN.pm 1.8854 and is
10074 still considered beta quality)
10075
10076 Distributions on the CPAN usually behave according to what we call the
10077 CPAN mantra. Or since the event of Module::Build we should talk about
10078 two mantras:
10079
10080     perl Makefile.PL     perl Build.PL
10081     make                 ./Build
10082     make test            ./Build test
10083     make install         ./Build install
10084
10085 But some modules cannot be built with this mantra. They try to get
10086 some extra data from the user via the environment, extra arguments or
10087 interactively thus disturbing the installation of large bundles like
10088 Phalanx100 or modules with many dependencies like Plagger.
10089
10090 The distroprefs system of C<CPAN.pm> addresses this problem by
10091 allowing the user to specify extra informations and recipes in YAML
10092 files to either
10093
10094 =over
10095
10096 =item
10097
10098 pass additional arguments to one of the four commands,
10099
10100 =item
10101
10102 set environment variables
10103
10104 =item
10105
10106 instantiate an Expect object that reads from the console, waits for
10107 some regular expressions and enters some answers
10108
10109 =item
10110
10111 temporarily override assorted C<CPAN.pm> configuration variables
10112
10113 =item
10114
10115 disable the installation of an object altogether
10116
10117 =back
10118
10119 See the YAML and Data::Dumper files that come with the C<CPAN.pm>
10120 distribution in the C<distroprefs/> directory for examples.
10121
10122 =head2 Filenames
10123
10124 The YAML files themselves must have the C<.yml> extension, all other
10125 files are ignored (for two exceptions see I<Fallback Data::Dumper and
10126 Storable> below). The containing directory can be specified in
10127 C<CPAN.pm> in the C<prefs_dir> config variable. Try C<o conf init
10128 prefs_dir> in the CPAN shell to set and activate the distroprefs
10129 system.
10130
10131 Every YAML file may contain arbitrary documents according to the YAML
10132 specification and every single document is treated as an entity that
10133 can specify the treatment of a single distribution.
10134
10135 The names of the files can be picked freely, C<CPAN.pm> always reads
10136 all files (in alphabetical order) and takes the key C<match> (see
10137 below in I<Language Specs>) as a hashref containing match criteria
10138 that determine if the current distribution matches the YAML document
10139 or not.
10140
10141 =head2 Fallback Data::Dumper and Storable
10142
10143 If neither your configured C<yaml_module> nor YAML.pm is installed
10144 CPAN.pm falls back to using Data::Dumper and Storable and looks for
10145 files with the extensions C<.dd> or C<.st> in the C<prefs_dir>
10146 directory. These files are expected to contain one or more hashrefs.
10147 For Data::Dumper generated files, this is expected to be done with by
10148 defining C<$VAR1>, C<$VAR2>, etc. The YAML shell would produce these
10149 with the command
10150
10151     ysh < somefile.yml > somefile.dd
10152
10153 For Storable files the rule is that they must be constructed such that
10154 C<Storable::retrieve(file)> returns an array reference and the array
10155 elements represent one distropref object each. The conversion from
10156 YAML would look like so:
10157
10158     perl -MYAML=LoadFile -MStorable=nstore -e '
10159         @y=LoadFile(shift);
10160         nstore(\@y, shift)' somefile.yml somefile.st
10161
10162 In bootstrapping situations it is usually sufficient to translate only
10163 a few YAML files to Data::Dumper for the crucial modules like
10164 C<YAML::Syck>, C<YAML.pm> and C<Expect.pm>. If you prefer Storable
10165 over Data::Dumper, remember to pull out a Storable version that writes
10166 an older format than all the other Storable versions that will need to
10167 read them.
10168
10169 =head2 Blueprint
10170
10171 The following example contains all supported keywords and structures
10172 with the exception of C<eexpect> which can be used instead of
10173 C<expect>.
10174
10175   ---
10176   comment: "Demo"
10177   match:
10178     module: "Dancing::Queen"
10179     distribution: "^CHACHACHA/Dancing-"
10180     perl: "/usr/local/cariba-perl/bin/perl"
10181   disabled: 1
10182   cpanconfig:
10183     make: gmake
10184   pl:
10185     args:
10186       - "--somearg=specialcase"
10187
10188     env: {}
10189
10190     expect:
10191       - "Which is your favorite fruit"
10192       - "apple\n"
10193
10194   make:
10195     args:
10196       - all
10197       - extra-all
10198
10199     env: {}
10200
10201     expect: []
10202
10203     commendline: "echo SKIPPING make"
10204
10205   test:
10206     args: []
10207
10208     env: {}
10209
10210     expect: []
10211
10212   install:
10213     args: []
10214
10215     env:
10216       WANT_TO_INSTALL: YES
10217
10218     expect:
10219       - "Do you really want to install"
10220       - "y\n"
10221
10222   patches:
10223     - "ABCDE/Fedcba-3.14-ABCDE-01.patch"
10224
10225
10226 =head2 Language Specs
10227
10228 Every YAML document represents a single hash reference. The valid keys
10229 in this hash are as follows:
10230
10231 =over
10232
10233 =item comment [scalar]
10234
10235 A comment
10236
10237 =item cpanconfig [hash]
10238
10239 Temporarily override assorted C<CPAN.pm> configuration variables.
10240
10241 Supported are: C<build_requires_install_policy>, C<check_sigs>,
10242 C<make>, C<make_install_make_command>, C<prefer_installer>,
10243 C<test_report>. Please report as a bug when you need another one
10244 supported.
10245
10246 =item disabled [boolean]
10247
10248 Specifies that this distribution shall not be processed at all.
10249
10250 =item goto [string]
10251
10252 The canonical name of a delegate distribution that shall be installed
10253 instead. Useful when a new version, although it tests OK itself,
10254 breaks something else or a developer release or a fork is already
10255 uploaded that is better than the last released version.
10256
10257 =item install [hash]
10258
10259 Processing instructions for the C<make install> or C<./Build install>
10260 phase of the CPAN mantra. See below under I<Processiong Instructions>.
10261
10262 =item make [hash]
10263
10264 Processing instructions for the C<make> or C<./Build> phase of the
10265 CPAN mantra. See below under I<Processiong Instructions>.
10266
10267 =item match [hash]
10268
10269 A hashref with one or more of the keys C<distribution>, C<modules>, or
10270 C<perl> that specify if a document is targeted at a specific CPAN
10271 distribution.
10272
10273 The corresponding values are interpreted as regular expressions. The
10274 C<distribution> related one will be matched against the canonical
10275 distribution name, e.g. "AUTHOR/Foo-Bar-3.14.tar.gz".
10276
10277 The C<module> related one will be matched against I<all> modules
10278 contained in the distribution until one module matches.
10279
10280 The C<perl> related one will be matched against C<$^X>.
10281
10282 If more than one restriction of C<module>, C<distribution>, and
10283 C<perl> is specified, the results of the separately computed match
10284 values must all match. If this is the case then the hashref
10285 represented by the YAML document is returned as the preference
10286 structure for the current distribution.
10287
10288 =item patches [array]
10289
10290 An array of patches on CPAN or on the local disk to be applied in
10291 order via the external patch program. If the value for the C<-p>
10292 parameter is C<0> or C<1> is determined by reading the patch
10293 beforehand.
10294
10295 Note: if the C<applypatch> program is installed and C<CPAN::Config>
10296 knows about it B<and> a patch is written by the C<makepatch> program,
10297 then C<CPAN.pm> lets C<applypatch> apply the patch. Both C<makepatch>
10298 and C<applypatch> are available from CPAN in the C<JV/makepatch-*>
10299 distribution.
10300
10301 =item pl [hash]
10302
10303 Processing instructions for the C<perl Makefile.PL> or C<perl
10304 Build.PL> phase of the CPAN mantra. See below under I<Processiong
10305 Instructions>.
10306
10307 =item test [hash]
10308
10309 Processing instructions for the C<make test> or C<./Build test> phase
10310 of the CPAN mantra. See below under I<Processiong Instructions>.
10311
10312 =back
10313
10314 =head2 Processing Instructions
10315
10316 =over
10317
10318 =item args [array]
10319
10320 Arguments to be added to the command line
10321
10322 =item commandline
10323
10324 A full commandline that will be executed as it stands by a system
10325 call. During the execution the environment variable PERL will is set
10326 to $^X. If C<commandline> is specified, the content of C<args> is not
10327 used.
10328
10329 =item eexpect [hash]
10330
10331 Extended C<expect>. This is a hash reference with three allowed keys,
10332 C<mode>, C<timeout>, and C<talk>.
10333
10334 C<mode> may have the values C<deterministic> for the case where all
10335 questions come in the order written down and C<anyorder> for the case
10336 where the questions may come in any order. The default mode is
10337 C<deterministic>.
10338
10339 C<timeout> denotes a timeout in seconds. Floating point timeouts are
10340 OK. In the case of a C<mode=deterministic> the timeout denotes the
10341 timeout per question, in the case of C<mode=anyorder> it denotes the
10342 timeout per byte received from the stream or questions.
10343
10344 C<talk> is a reference to an array that contains alternating questions
10345 and answers. Questions are regular expressions and answers are literal
10346 strings. The Expect module will then watch the stream coming from the
10347 execution of the external program (C<perl Makefile.PL>, C<perl
10348 Build.PL>, C<make>, etc.).
10349
10350 In the case of C<mode=deterministic> the CPAN.pm will inject the
10351 according answer as soon as the stream matches the regular expression.
10352 In the case of C<mode=anyorder> the CPAN.pm will answer a question as
10353 soon as the timeout is reached for the next byte in the input stream.
10354 In the latter case it removes the according question/answer pair from
10355 the array, so if you want to answer the question C<Do you really want
10356 to do that> several times, then it must be included in the array at
10357 least as often as you want this answer to be given.
10358
10359 =item env [hash]
10360
10361 Environment variables to be set during the command
10362
10363 =item expect [array]
10364
10365 C<< expect: <array> >> is a short notation for
10366
10367   eexpect:
10368     mode: deterministic
10369     timeout: 15
10370     talk: <array>
10371
10372 =back
10373
10374 =head2 Schema verification with C<Kwalify>
10375
10376 If you have the C<Kwalify> module installed (which is part of the
10377 Bundle::CPANxxl), then all your distroprefs files are checked for
10378 syntactical correctness.
10379
10380 =head2 Example Distroprefs Files
10381
10382 C<CPAN.pm> comes with a collection of example YAML files. Note that these
10383 are really just examples and should not be used without care because
10384 they cannot fit everybody's purpose. After all the authors of the
10385 packages that ask questions had a need to ask, so you should watch
10386 their questions and adjust the examples to your environment and your
10387 needs. You have beend warned:-)
10388
10389 =head1 PROGRAMMER'S INTERFACE
10390
10391 If you do not enter the shell, the available shell commands are both
10392 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
10393 functions in the calling package (C<install(...)>).  Before calling low-level
10394 commands it makes sense to initialize components of CPAN you need, e.g.:
10395
10396   CPAN::HandleConfig->load;
10397   CPAN::Shell::setup_output;
10398   CPAN::Index->reload;
10399
10400 High-level commands do such initializations automatically.
10401
10402 There's currently only one class that has a stable interface -
10403 CPAN::Shell. All commands that are available in the CPAN shell are
10404 methods of the class CPAN::Shell. Each of the commands that produce
10405 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
10406 the IDs of all modules within the list.
10407
10408 =over 2
10409
10410 =item expand($type,@things)
10411
10412 The IDs of all objects available within a program are strings that can
10413 be expanded to the corresponding real objects with the
10414 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
10415 list of CPAN::Module objects according to the C<@things> arguments
10416 given. In scalar context it only returns the first element of the
10417 list.
10418
10419 =item expandany(@things)
10420
10421 Like expand, but returns objects of the appropriate type, i.e.
10422 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
10423 CPAN::Distribution objects for distributions. Note: it does not expand
10424 to CPAN::Author objects.
10425
10426 =item Programming Examples
10427
10428 This enables the programmer to do operations that combine
10429 functionalities that are available in the shell.
10430
10431     # install everything that is outdated on my disk:
10432     perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
10433
10434     # install my favorite programs if necessary:
10435     for $mod (qw(Net::FTP Digest::SHA Data::Dumper)){
10436         CPAN::Shell->install($mod);
10437     }
10438
10439     # list all modules on my disk that have no VERSION number
10440     for $mod (CPAN::Shell->expand("Module","/./")){
10441         next unless $mod->inst_file;
10442         # MakeMaker convention for undefined $VERSION:
10443         next unless $mod->inst_version eq "undef";
10444         print "No VERSION in ", $mod->id, "\n";
10445     }
10446
10447     # find out which distribution on CPAN contains a module:
10448     print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
10449
10450 Or if you want to write a cronjob to watch The CPAN, you could list
10451 all modules that need updating. First a quick and dirty way:
10452
10453     perl -e 'use CPAN; CPAN::Shell->r;'
10454
10455 If you don't want to get any output in the case that all modules are
10456 up to date, you can parse the output of above command for the regular
10457 expression //modules are up to date// and decide to mail the output
10458 only if it doesn't match. Ick?
10459
10460 If you prefer to do it more in a programmer style in one single
10461 process, maybe something like this suits you better:
10462
10463   # list all modules on my disk that have newer versions on CPAN
10464   for $mod (CPAN::Shell->expand("Module","/./")){
10465     next unless $mod->inst_file;
10466     next if $mod->uptodate;
10467     printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
10468         $mod->id, $mod->inst_version, $mod->cpan_version;
10469   }
10470
10471 If that gives you too much output every day, you maybe only want to
10472 watch for three modules. You can write
10473
10474   for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
10475
10476 as the first line instead. Or you can combine some of the above
10477 tricks:
10478
10479   # watch only for a new mod_perl module
10480   $mod = CPAN::Shell->expand("Module","mod_perl");
10481   exit if $mod->uptodate;
10482   # new mod_perl arrived, let me know all update recommendations
10483   CPAN::Shell->r;
10484
10485 =back
10486
10487 =head2 Methods in the other Classes
10488
10489 =over 4
10490
10491 =item CPAN::Author::as_glimpse()
10492
10493 Returns a one-line description of the author
10494
10495 =item CPAN::Author::as_string()
10496
10497 Returns a multi-line description of the author
10498
10499 =item CPAN::Author::email()
10500
10501 Returns the author's email address
10502
10503 =item CPAN::Author::fullname()
10504
10505 Returns the author's name
10506
10507 =item CPAN::Author::name()
10508
10509 An alias for fullname
10510
10511 =item CPAN::Bundle::as_glimpse()
10512
10513 Returns a one-line description of the bundle
10514
10515 =item CPAN::Bundle::as_string()
10516
10517 Returns a multi-line description of the bundle
10518
10519 =item CPAN::Bundle::clean()
10520
10521 Recursively runs the C<clean> method on all items contained in the bundle.
10522
10523 =item CPAN::Bundle::contains()
10524
10525 Returns a list of objects' IDs contained in a bundle. The associated
10526 objects may be bundles, modules or distributions.
10527
10528 =item CPAN::Bundle::force($method,@args)
10529
10530 Forces CPAN to perform a task that it normally would have refused to
10531 do. Force takes as arguments a method name to be called and any number
10532 of additional arguments that should be passed to the called method.
10533 The internals of the object get the needed changes so that CPAN.pm
10534 does not refuse to take the action. The C<force> is passed recursively
10535 to all contained objects. See also the section above on the C<force>
10536 and the C<fforce> pragma.
10537
10538 =item CPAN::Bundle::get()
10539
10540 Recursively runs the C<get> method on all items contained in the bundle
10541
10542 =item CPAN::Bundle::inst_file()
10543
10544 Returns the highest installed version of the bundle in either @INC or
10545 C<$CPAN::Config->{cpan_home}>. Note that this is different from
10546 CPAN::Module::inst_file.
10547
10548 =item CPAN::Bundle::inst_version()
10549
10550 Like CPAN::Bundle::inst_file, but returns the $VERSION
10551
10552 =item CPAN::Bundle::uptodate()
10553
10554 Returns 1 if the bundle itself and all its members are uptodate.
10555
10556 =item CPAN::Bundle::install()
10557
10558 Recursively runs the C<install> method on all items contained in the bundle
10559
10560 =item CPAN::Bundle::make()
10561
10562 Recursively runs the C<make> method on all items contained in the bundle
10563
10564 =item CPAN::Bundle::readme()
10565
10566 Recursively runs the C<readme> method on all items contained in the bundle
10567
10568 =item CPAN::Bundle::test()
10569
10570 Recursively runs the C<test> method on all items contained in the bundle
10571
10572 =item CPAN::Distribution::as_glimpse()
10573
10574 Returns a one-line description of the distribution
10575
10576 =item CPAN::Distribution::as_string()
10577
10578 Returns a multi-line description of the distribution
10579
10580 =item CPAN::Distribution::author
10581
10582 Returns the CPAN::Author object of the maintainer who uploaded this
10583 distribution
10584
10585 =item CPAN::Distribution::clean()
10586
10587 Changes to the directory where the distribution has been unpacked and
10588 runs C<make clean> there.
10589
10590 =item CPAN::Distribution::containsmods()
10591
10592 Returns a list of IDs of modules contained in a distribution file.
10593 Only works for distributions listed in the 02packages.details.txt.gz
10594 file. This typically means that only the most recent version of a
10595 distribution is covered.
10596
10597 =item CPAN::Distribution::cvs_import()
10598
10599 Changes to the directory where the distribution has been unpacked and
10600 runs something like
10601
10602     cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
10603
10604 there.
10605
10606 =item CPAN::Distribution::dir()
10607
10608 Returns the directory into which this distribution has been unpacked.
10609
10610 =item CPAN::Distribution::force($method,@args)
10611
10612 Forces CPAN to perform a task that it normally would have refused to
10613 do. Force takes as arguments a method name to be called and any number
10614 of additional arguments that should be passed to the called method.
10615 The internals of the object get the needed changes so that CPAN.pm
10616 does not refuse to take the action. See also the section above on the
10617 C<force> and the C<fforce> pragma.
10618
10619 =item CPAN::Distribution::get()
10620
10621 Downloads the distribution from CPAN and unpacks it. Does nothing if
10622 the distribution has already been downloaded and unpacked within the
10623 current session.
10624
10625 =item CPAN::Distribution::install()
10626
10627 Changes to the directory where the distribution has been unpacked and
10628 runs the external command C<make install> there. If C<make> has not
10629 yet been run, it will be run first. A C<make test> will be issued in
10630 any case and if this fails, the install will be canceled. The
10631 cancellation can be avoided by letting C<force> run the C<install> for
10632 you.
10633
10634 This install method has only the power to install the distribution if
10635 there are no dependencies in the way. To install an object and all of
10636 its dependencies, use CPAN::Shell->install.
10637
10638 Note that install() gives no meaningful return value. See uptodate().
10639
10640 =item CPAN::Distribution::install_tested()
10641
10642 Install all the distributions that have been tested sucessfully but
10643 not yet installed. See also C<is_tested>.
10644
10645 =item CPAN::Distribution::isa_perl()
10646
10647 Returns 1 if this distribution file seems to be a perl distribution.
10648 Normally this is derived from the file name only, but the index from
10649 CPAN can contain a hint to achieve a return value of true for other
10650 filenames too.
10651
10652 =item CPAN::Distribution::is_tested()
10653
10654 List all the distributions that have been tested sucessfully but not
10655 yet installed. See also C<install_tested>.
10656
10657 =item CPAN::Distribution::look()
10658
10659 Changes to the directory where the distribution has been unpacked and
10660 opens a subshell there. Exiting the subshell returns.
10661
10662 =item CPAN::Distribution::make()
10663
10664 First runs the C<get> method to make sure the distribution is
10665 downloaded and unpacked. Changes to the directory where the
10666 distribution has been unpacked and runs the external commands C<perl
10667 Makefile.PL> or C<perl Build.PL> and C<make> there.
10668
10669 =item CPAN::Distribution::perldoc()
10670
10671 Downloads the pod documentation of the file associated with a
10672 distribution (in html format) and runs it through the external
10673 command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
10674 isn't available, it converts it to plain text with external
10675 command html2text and runs it through the pager specified
10676 in C<$CPAN::Config->{pager}>
10677
10678 =item CPAN::Distribution::prefs()
10679
10680 Returns the hash reference from the first matching YAML file that the
10681 user has deposited in the C<prefs_dir/> directory. The first
10682 succeeding match wins. The files in the C<prefs_dir/> are processed
10683 alphabetically and the canonical distroname (e.g.
10684 AUTHOR/Foo-Bar-3.14.tar.gz) is matched against the regular expressions
10685 stored in the $root->{match}{distribution} attribute value.
10686 Additionally all module names contained in a distribution are matched
10687 agains the regular expressions in the $root->{match}{module} attribute
10688 value. The two match values are ANDed together. Each of the two
10689 attributes are optional.
10690
10691 =item CPAN::Distribution::prereq_pm()
10692
10693 Returns the hash reference that has been announced by a distribution
10694 as the the C<requires> and C<build_requires> elements. These can be
10695 declared either by the C<META.yml> (if authoritative) or can be
10696 deposited after the run of C<Build.PL> in the file C<./_build/prereqs>
10697 or after the run of C<Makfile.PL> written as the C<PREREQ_PM> hash in
10698 a comment in the produced C<Makefile>. I<Note>: this method only works
10699 after an attempt has been made to C<make> the distribution. Returns
10700 undef otherwise.
10701
10702 =item CPAN::Distribution::readme()
10703
10704 Downloads the README file associated with a distribution and runs it
10705 through the pager specified in C<$CPAN::Config->{pager}>.
10706
10707 =item CPAN::Distribution::read_yaml()
10708
10709 Returns the content of the META.yml of this distro as a hashref. Note:
10710 works only after an attempt has been made to C<make> the distribution.
10711 Returns undef otherwise. Also returns undef if the content of META.yml
10712 is not authoritative. (The rules about what exactly makes the content
10713 authoritative are still in flux.)
10714
10715 =item CPAN::Distribution::test()
10716
10717 Changes to the directory where the distribution has been unpacked and
10718 runs C<make test> there.
10719
10720 =item CPAN::Distribution::uptodate()
10721
10722 Returns 1 if all the modules contained in the distribution are
10723 uptodate. Relies on containsmods.
10724
10725 =item CPAN::Index::force_reload()
10726
10727 Forces a reload of all indices.
10728
10729 =item CPAN::Index::reload()
10730
10731 Reloads all indices if they have not been read for more than
10732 C<$CPAN::Config->{index_expire}> days.
10733
10734 =item CPAN::InfoObj::dump()
10735
10736 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
10737 inherit this method. It prints the data structure associated with an
10738 object. Useful for debugging. Note: the data structure is considered
10739 internal and thus subject to change without notice.
10740
10741 =item CPAN::Module::as_glimpse()
10742
10743 Returns a one-line description of the module in four columns: The
10744 first column contains the word C<Module>, the second column consists
10745 of one character: an equals sign if this module is already installed
10746 and uptodate, a less-than sign if this module is installed but can be
10747 upgraded, and a space if the module is not installed. The third column
10748 is the name of the module and the fourth column gives maintainer or
10749 distribution information.
10750
10751 =item CPAN::Module::as_string()
10752
10753 Returns a multi-line description of the module
10754
10755 =item CPAN::Module::clean()
10756
10757 Runs a clean on the distribution associated with this module.
10758
10759 =item CPAN::Module::cpan_file()
10760
10761 Returns the filename on CPAN that is associated with the module.
10762
10763 =item CPAN::Module::cpan_version()
10764
10765 Returns the latest version of this module available on CPAN.
10766
10767 =item CPAN::Module::cvs_import()
10768
10769 Runs a cvs_import on the distribution associated with this module.
10770
10771 =item CPAN::Module::description()
10772
10773 Returns a 44 character description of this module. Only available for
10774 modules listed in The Module List (CPAN/modules/00modlist.long.html
10775 or 00modlist.long.txt.gz)
10776
10777 =item CPAN::Module::distribution()
10778
10779 Returns the CPAN::Distribution object that contains the current
10780 version of this module.
10781
10782 =item CPAN::Module::dslip_status()
10783
10784 Returns a hash reference. The keys of the hash are the letters C<D>,
10785 C<S>, C<L>, C<I>, and <P>, for development status, support level,
10786 language, interface and public licence respectively. The data for the
10787 DSLIP status are collected by pause.perl.org when authors register
10788 their namespaces. The values of the 5 hash elements are one-character
10789 words whose meaning is described in the table below. There are also 5
10790 hash elements C<DV>, C<SV>, C<LV>, C<IV>, and <PV> that carry a more
10791 verbose value of the 5 status variables.
10792
10793 Where the 'DSLIP' characters have the following meanings:
10794
10795   D - Development Stage  (Note: *NO IMPLIED TIMESCALES*):
10796     i   - Idea, listed to gain consensus or as a placeholder
10797     c   - under construction but pre-alpha (not yet released)
10798     a/b - Alpha/Beta testing
10799     R   - Released
10800     M   - Mature (no rigorous definition)
10801     S   - Standard, supplied with Perl 5
10802
10803   S - Support Level:
10804     m   - Mailing-list
10805     d   - Developer
10806     u   - Usenet newsgroup comp.lang.perl.modules
10807     n   - None known, try comp.lang.perl.modules
10808     a   - abandoned; volunteers welcome to take over maintainance
10809
10810   L - Language Used:
10811     p   - Perl-only, no compiler needed, should be platform independent
10812     c   - C and perl, a C compiler will be needed
10813     h   - Hybrid, written in perl with optional C code, no compiler needed
10814     +   - C++ and perl, a C++ compiler will be needed
10815     o   - perl and another language other than C or C++
10816
10817   I - Interface Style
10818     f   - plain Functions, no references used
10819     h   - hybrid, object and function interfaces available
10820     n   - no interface at all (huh?)
10821     r   - some use of unblessed References or ties
10822     O   - Object oriented using blessed references and/or inheritance
10823
10824   P - Public License
10825     p   - Standard-Perl: user may choose between GPL and Artistic
10826     g   - GPL: GNU General Public License
10827     l   - LGPL: "GNU Lesser General Public License" (previously known as
10828           "GNU Library General Public License")
10829     b   - BSD: The BSD License
10830     a   - Artistic license alone
10831     o   - open source: appoved by www.opensource.org
10832     d   - allows distribution without restrictions
10833     r   - restricted distribtion
10834     n   - no license at all
10835
10836 =item CPAN::Module::force($method,@args)
10837
10838 Forces CPAN to perform a task that it normally would have refused to
10839 do. Force takes as arguments a method name to be called and any number
10840 of additional arguments that should be passed to the called method.
10841 The internals of the object get the needed changes so that CPAN.pm
10842 does not refuse to take the action. See also the section above on the
10843 C<force> and the C<fforce> pragma.
10844
10845 =item CPAN::Module::get()
10846
10847 Runs a get on the distribution associated with this module.
10848
10849 =item CPAN::Module::inst_file()
10850
10851 Returns the filename of the module found in @INC. The first file found
10852 is reported just like perl itself stops searching @INC when it finds a
10853 module.
10854
10855 =item CPAN::Module::available_file()
10856
10857 Returns the filename of the module found in PERL5LIB or @INC. The
10858 first file found is reported. The advantage of this method over
10859 C<inst_file> is that modules that have been tested but not yet
10860 installed are included because PERL5LIB keeps track of tested modules.
10861
10862 =item CPAN::Module::inst_version()
10863
10864 Returns the version number of the installed module in readable format.
10865
10866 =item CPAN::Module::available_version()
10867
10868 Returns the version number of the available module in readable format.
10869
10870 =item CPAN::Module::install()
10871
10872 Runs an C<install> on the distribution associated with this module.
10873
10874 =item CPAN::Module::look()
10875
10876 Changes to the directory where the distribution associated with this
10877 module has been unpacked and opens a subshell there. Exiting the
10878 subshell returns.
10879
10880 =item CPAN::Module::make()
10881
10882 Runs a C<make> on the distribution associated with this module.
10883
10884 =item CPAN::Module::manpage_headline()
10885
10886 If module is installed, peeks into the module's manpage, reads the
10887 headline and returns it. Moreover, if the module has been downloaded
10888 within this session, does the equivalent on the downloaded module even
10889 if it is not installed.
10890
10891 =item CPAN::Module::perldoc()
10892
10893 Runs a C<perldoc> on this module.
10894
10895 =item CPAN::Module::readme()
10896
10897 Runs a C<readme> on the distribution associated with this module.
10898
10899 =item CPAN::Module::test()
10900
10901 Runs a C<test> on the distribution associated with this module.
10902
10903 =item CPAN::Module::uptodate()
10904
10905 Returns 1 if the module is installed and up-to-date.
10906
10907 =item CPAN::Module::userid()
10908
10909 Returns the author's ID of the module.
10910
10911 =back
10912
10913 =head2 Cache Manager
10914
10915 Currently the cache manager only keeps track of the build directory
10916 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
10917 deletes complete directories below C<build_dir> as soon as the size of
10918 all directories there gets bigger than $CPAN::Config->{build_cache}
10919 (in MB). The contents of this cache may be used for later
10920 re-installations that you intend to do manually, but will never be
10921 trusted by CPAN itself. This is due to the fact that the user might
10922 use these directories for building modules on different architectures.
10923
10924 There is another directory ($CPAN::Config->{keep_source_where}) where
10925 the original distribution files are kept. This directory is not
10926 covered by the cache manager and must be controlled by the user. If
10927 you choose to have the same directory as build_dir and as
10928 keep_source_where directory, then your sources will be deleted with
10929 the same fifo mechanism.
10930
10931 =head2 Bundles
10932
10933 A bundle is just a perl module in the namespace Bundle:: that does not
10934 define any functions or methods. It usually only contains documentation.
10935
10936 It starts like a perl module with a package declaration and a $VERSION
10937 variable. After that the pod section looks like any other pod with the
10938 only difference being that I<one special pod section> exists starting with
10939 (verbatim):
10940
10941         =head1 CONTENTS
10942
10943 In this pod section each line obeys the format
10944
10945         Module_Name [Version_String] [- optional text]
10946
10947 The only required part is the first field, the name of a module
10948 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
10949 of the line is optional. The comment part is delimited by a dash just
10950 as in the man page header.
10951
10952 The distribution of a bundle should follow the same convention as
10953 other distributions.
10954
10955 Bundles are treated specially in the CPAN package. If you say 'install
10956 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
10957 the modules in the CONTENTS section of the pod. You can install your
10958 own Bundles locally by placing a conformant Bundle file somewhere into
10959 your @INC path. The autobundle() command which is available in the
10960 shell interface does that for you by including all currently installed
10961 modules in a snapshot bundle file.
10962
10963 =head1 PREREQUISITES
10964
10965 If you have a local mirror of CPAN and can access all files with
10966 "file:" URLs, then you only need a perl better than perl5.003 to run
10967 this module. Otherwise Net::FTP is strongly recommended. LWP may be
10968 required for non-UNIX systems or if your nearest CPAN site is
10969 associated with a URL that is not C<ftp:>.
10970
10971 If you have neither Net::FTP nor LWP, there is a fallback mechanism
10972 implemented for an external ftp command or for an external lynx
10973 command.
10974
10975 =head1 UTILITIES
10976
10977 =head2 Finding packages and VERSION
10978
10979 This module presumes that all packages on CPAN
10980
10981 =over 2
10982
10983 =item *
10984
10985 declare their $VERSION variable in an easy to parse manner. This
10986 prerequisite can hardly be relaxed because it consumes far too much
10987 memory to load all packages into the running program just to determine
10988 the $VERSION variable. Currently all programs that are dealing with
10989 version use something like this
10990
10991     perl -MExtUtils::MakeMaker -le \
10992         'print MM->parse_version(shift)' filename
10993
10994 If you are author of a package and wonder if your $VERSION can be
10995 parsed, please try the above method.
10996
10997 =item *
10998
10999 come as compressed or gzipped tarfiles or as zip files and contain a
11000 C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
11001 without much enthusiasm).
11002
11003 =back
11004
11005 =head2 Debugging
11006
11007 The debugging of this module is a bit complex, because we have
11008 interferences of the software producing the indices on CPAN, of the
11009 mirroring process on CPAN, of packaging, of configuration, of
11010 synchronicity, and of bugs within CPAN.pm.
11011
11012 For debugging the code of CPAN.pm itself in interactive mode some more
11013 or less useful debugging aid can be turned on for most packages within
11014 CPAN.pm with one of
11015
11016 =over 2
11017
11018 =item o debug package...
11019
11020 sets debug mode for packages.
11021
11022 =item o debug -package...
11023
11024 unsets debug mode for packages.
11025
11026 =item o debug all
11027
11028 turns debugging on for all packages.
11029
11030 =item o debug number
11031
11032 =back
11033
11034 which sets the debugging packages directly. Note that C<o debug 0>
11035 turns debugging off.
11036
11037 What seems quite a successful strategy is the combination of C<reload
11038 cpan> and the debugging switches. Add a new debug statement while
11039 running in the shell and then issue a C<reload cpan> and see the new
11040 debugging messages immediately without losing the current context.
11041
11042 C<o debug> without an argument lists the valid package names and the
11043 current set of packages in debugging mode. C<o debug> has built-in
11044 completion support.
11045
11046 For debugging of CPAN data there is the C<dump> command which takes
11047 the same arguments as make/test/install and outputs each object's
11048 Data::Dumper dump. If an argument looks like a perl variable and
11049 contains one of C<$>, C<@> or C<%>, it is eval()ed and fed to
11050 Data::Dumper directly.
11051
11052 =head2 Floppy, Zip, Offline Mode
11053
11054 CPAN.pm works nicely without network too. If you maintain machines
11055 that are not networked at all, you should consider working with file:
11056 URLs. Of course, you have to collect your modules somewhere first. So
11057 you might use CPAN.pm to put together all you need on a networked
11058 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
11059 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
11060 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
11061 with this floppy. See also below the paragraph about CD-ROM support.
11062
11063 =head2 Basic Utilities for Programmers
11064
11065 =over 2
11066
11067 =item has_inst($module)
11068
11069 Returns true if the module is installed. Used to load all modules into
11070 the running CPAN.pm which are considered optional. The config variable
11071 C<dontload_list> can be used to intercept the C<has_inst()> call such
11072 that an optional module is not loaded despite being available. For
11073 example the following command will prevent that C<YAML.pm> is being
11074 loaded:
11075
11076     cpan> o conf dontload_list push YAML
11077
11078 See the source for details.
11079
11080 =item has_usable($module)
11081
11082 Returns true if the module is installed and is in a usable state. Only
11083 useful for a handful of modules that are used internally. See the
11084 source for details.
11085
11086 =item instance($module)
11087
11088 The constructor for all the singletons used to represent modules,
11089 distributions, authors and bundles. If the object already exists, this
11090 method returns the object, otherwise it calls the constructor.
11091
11092 =back
11093
11094 =head1 SECURITY
11095
11096 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
11097 install foreign, unmasked, unsigned code on your machine. We compare
11098 to a checksum that comes from the net just as the distribution file
11099 itself. But we try to make it easy to add security on demand:
11100
11101 =head2 Cryptographically signed modules
11102
11103 Since release 1.77 CPAN.pm has been able to verify cryptographically
11104 signed module distributions using Module::Signature.  The CPAN modules
11105 can be signed by their authors, thus giving more security.  The simple
11106 unsigned MD5 checksums that were used before by CPAN protect mainly
11107 against accidental file corruption.
11108
11109 You will need to have Module::Signature installed, which in turn
11110 requires that you have at least one of Crypt::OpenPGP module or the
11111 command-line F<gpg> tool installed.
11112
11113 You will also need to be able to connect over the Internet to the public
11114 keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
11115
11116 The configuration parameter check_sigs is there to turn signature
11117 checking on or off.
11118
11119 =head1 EXPORT
11120
11121 Most functions in package CPAN are exported per default. The reason
11122 for this is that the primary use is intended for the cpan shell or for
11123 one-liners.
11124
11125 =head1 ENVIRONMENT
11126
11127 When the CPAN shell enters a subshell via the look command, it sets
11128 the environment CPAN_SHELL_LEVEL to 1 or increments it if it is
11129 already set.
11130
11131 When CPAN runs, it sets the environment variable PERL5_CPAN_IS_RUNNING.
11132
11133 When the config variable ftp_passive is set, all downloads will be run
11134 with the environment variable FTP_PASSIVE set to this value. This is
11135 in general a good idea as it influences both Net::FTP and LWP based
11136 connections. The same effect can be achieved by starting the cpan
11137 shell with this environment variable set. For Net::FTP alone, one can
11138 also always set passive mode by running libnetcfg.
11139
11140 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
11141
11142 Populating a freshly installed perl with my favorite modules is pretty
11143 easy if you maintain a private bundle definition file. To get a useful
11144 blueprint of a bundle definition file, the command autobundle can be used
11145 on the CPAN shell command line. This command writes a bundle definition
11146 file for all modules that are installed for the currently running perl
11147 interpreter. It's recommended to run this command only once and from then
11148 on maintain the file manually under a private name, say
11149 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
11150
11151     cpan> install Bundle::my_bundle
11152
11153 then answer a few questions and then go out for a coffee.
11154
11155 Maintaining a bundle definition file means keeping track of two
11156 things: dependencies and interactivity. CPAN.pm sometimes fails on
11157 calculating dependencies because not all modules define all MakeMaker
11158 attributes correctly, so a bundle definition file should specify
11159 prerequisites as early as possible. On the other hand, it's a bit
11160 annoying that many distributions need some interactive configuring. So
11161 what I try to accomplish in my private bundle file is to have the
11162 packages that need to be configured early in the file and the gentle
11163 ones later, so I can go out after a few minutes and leave CPAN.pm
11164 untended.
11165
11166 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
11167
11168 Thanks to Graham Barr for contributing the following paragraphs about
11169 the interaction between perl, and various firewall configurations. For
11170 further information on firewalls, it is recommended to consult the
11171 documentation that comes with the ncftp program. If you are unable to
11172 go through the firewall with a simple Perl setup, it is very likely
11173 that you can configure ncftp so that it works for your firewall.
11174
11175 =head2 Three basic types of firewalls
11176
11177 Firewalls can be categorized into three basic types.
11178
11179 =over 4
11180
11181 =item http firewall
11182
11183 This is where the firewall machine runs a web server and to access the
11184 outside world you must do it via the web server. If you set environment
11185 variables like http_proxy or ftp_proxy to a values beginning with http://
11186 or in your web browser you have to set proxy information then you know
11187 you are running an http firewall.
11188
11189 To access servers outside these types of firewalls with perl (even for
11190 ftp) you will need to use LWP.
11191
11192 =item ftp firewall
11193
11194 This where the firewall machine runs an ftp server. This kind of
11195 firewall will only let you access ftp servers outside the firewall.
11196 This is usually done by connecting to the firewall with ftp, then
11197 entering a username like "user@outside.host.com"
11198
11199 To access servers outside these type of firewalls with perl you
11200 will need to use Net::FTP.
11201
11202 =item One way visibility
11203
11204 I say one way visibility as these firewalls try to make themselves look
11205 invisible to the users inside the firewall. An FTP data connection is
11206 normally created by sending the remote server your IP address and then
11207 listening for the connection. But the remote server will not be able to
11208 connect to you because of the firewall. So for these types of firewall
11209 FTP connections need to be done in a passive mode.
11210
11211 There are two that I can think off.
11212
11213 =over 4
11214
11215 =item SOCKS
11216
11217 If you are using a SOCKS firewall you will need to compile perl and link
11218 it with the SOCKS library, this is what is normally called a 'socksified'
11219 perl. With this executable you will be able to connect to servers outside
11220 the firewall as if it is not there.
11221
11222 =item IP Masquerade
11223
11224 This is the firewall implemented in the Linux kernel, it allows you to
11225 hide a complete network behind one IP address. With this firewall no
11226 special compiling is needed as you can access hosts directly.
11227
11228 For accessing ftp servers behind such firewalls you usually need to
11229 set the environment variable C<FTP_PASSIVE> or the config variable
11230 ftp_passive to a true value.
11231
11232 =back
11233
11234 =back
11235
11236 =head2 Configuring lynx or ncftp for going through a firewall
11237
11238 If you can go through your firewall with e.g. lynx, presumably with a
11239 command such as
11240
11241     /usr/local/bin/lynx -pscott:tiger
11242
11243 then you would configure CPAN.pm with the command
11244
11245     o conf lynx "/usr/local/bin/lynx -pscott:tiger"
11246
11247 That's all. Similarly for ncftp or ftp, you would configure something
11248 like
11249
11250     o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
11251
11252 Your mileage may vary...
11253
11254 =head1 FAQ
11255
11256 =over 4
11257
11258 =item 1)
11259
11260 I installed a new version of module X but CPAN keeps saying,
11261 I have the old version installed
11262
11263 Most probably you B<do> have the old version installed. This can
11264 happen if a module installs itself into a different directory in the
11265 @INC path than it was previously installed. This is not really a
11266 CPAN.pm problem, you would have the same problem when installing the
11267 module manually. The easiest way to prevent this behaviour is to add
11268 the argument C<UNINST=1> to the C<make install> call, and that is why
11269 many people add this argument permanently by configuring
11270
11271   o conf make_install_arg UNINST=1
11272
11273 =item 2)
11274
11275 So why is UNINST=1 not the default?
11276
11277 Because there are people who have their precise expectations about who
11278 may install where in the @INC path and who uses which @INC array. In
11279 fine tuned environments C<UNINST=1> can cause damage.
11280
11281 =item 3)
11282
11283 I want to clean up my mess, and install a new perl along with
11284 all modules I have. How do I go about it?
11285
11286 Run the autobundle command for your old perl and optionally rename the
11287 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
11288 with the Configure option prefix, e.g.
11289
11290     ./Configure -Dprefix=/usr/local/perl-5.6.78.9
11291
11292 Install the bundle file you produced in the first step with something like
11293
11294     cpan> install Bundle::mybundle
11295
11296 and you're done.
11297
11298 =item 4)
11299
11300 When I install bundles or multiple modules with one command
11301 there is too much output to keep track of.
11302
11303 You may want to configure something like
11304
11305   o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
11306   o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
11307
11308 so that STDOUT is captured in a file for later inspection.
11309
11310
11311 =item 5)
11312
11313 I am not root, how can I install a module in a personal directory?
11314
11315 First of all, you will want to use your own configuration, not the one
11316 that your root user installed. If you do not have permission to write
11317 in the cpan directory that root has configured, you will be asked if
11318 you want to create your own config. Answering "yes" will bring you into
11319 CPAN's configuration stage, using the system config for all defaults except
11320 things that have to do with CPAN's work directory, saving your choices to
11321 your MyConfig.pm file.
11322
11323 You can also manually initiate this process with the following command:
11324
11325     % perl -MCPAN -e 'mkmyconfig'
11326
11327 or by running
11328
11329     mkmyconfig
11330
11331 from the CPAN shell.
11332
11333 You will most probably also want to configure something like this:
11334
11335   o conf makepl_arg "LIB=~/myperl/lib \
11336                     INSTALLMAN1DIR=~/myperl/man/man1 \
11337                     INSTALLMAN3DIR=~/myperl/man/man3 \
11338                     INSTALLSCRIPT=~/myperl/bin \
11339                     INSTALLBIN=~/myperl/bin"
11340
11341 and then (oh joy) the equivalent command for Module::Build.
11342
11343 You can make this setting permanent like all C<o conf> settings with
11344 C<o conf commit> or by setting C<auto_commit> beforehand.
11345
11346 You will have to add ~/myperl/man to the MANPATH environment variable
11347 and also tell your perl programs to look into ~/myperl/lib, e.g. by
11348 including
11349
11350   use lib "$ENV{HOME}/myperl/lib";
11351
11352 or setting the PERL5LIB environment variable.
11353
11354 While we're speaking about $ENV{HOME}, it might be worth mentioning,
11355 that for Windows we use the File::HomeDir module that provides an
11356 equivalent to the concept of the home directory on Unix.
11357
11358 Another thing you should bear in mind is that the UNINST parameter can
11359 be dnagerous when you are installing into a private area because you
11360 might accidentally remove modules that other people depend on that are
11361 not using the private area.
11362
11363 =item 6)
11364
11365 How to get a package, unwrap it, and make a change before building it?
11366
11367 Have a look at the C<look> (!) command.
11368
11369 =item 7)
11370
11371 I installed a Bundle and had a couple of fails. When I
11372 retried, everything resolved nicely. Can this be fixed to work
11373 on first try?
11374
11375 The reason for this is that CPAN does not know the dependencies of all
11376 modules when it starts out. To decide about the additional items to
11377 install, it just uses data found in the META.yml file or the generated
11378 Makefile. An undetected missing piece breaks the process. But it may
11379 well be that your Bundle installs some prerequisite later than some
11380 depending item and thus your second try is able to resolve everything.
11381 Please note, CPAN.pm does not know the dependency tree in advance and
11382 cannot sort the queue of things to install in a topologically correct
11383 order. It resolves perfectly well IF all modules declare the
11384 prerequisites correctly with the PREREQ_PM attribute to MakeMaker or
11385 the C<requires> stanza of Module::Build. For bundles which fail and
11386 you need to install often, it is recommended to sort the Bundle
11387 definition file manually.
11388
11389 =item 8)
11390
11391 In our intranet we have many modules for internal use. How
11392 can I integrate these modules with CPAN.pm but without uploading
11393 the modules to CPAN?
11394
11395 Have a look at the CPAN::Site module.
11396
11397 =item 9)
11398
11399 When I run CPAN's shell, I get an error message about things in my
11400 /etc/inputrc (or ~/.inputrc) file.
11401
11402 These are readline issues and can only be fixed by studying readline
11403 configuration on your architecture and adjusting the referenced file
11404 accordingly. Please make a backup of the /etc/inputrc or ~/.inputrc
11405 and edit them. Quite often harmless changes like uppercasing or
11406 lowercasing some arguments solves the problem.
11407
11408 =item 10)
11409
11410 Some authors have strange characters in their names.
11411
11412 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
11413 expecting ISO-8859-1 charset, a converter can be activated by setting
11414 term_is_latin to a true value in your config file. One way of doing so
11415 would be
11416
11417     cpan> o conf term_is_latin 1
11418
11419 If other charset support is needed, please file a bugreport against
11420 CPAN.pm at rt.cpan.org and describe your needs. Maybe we can extend
11421 the support or maybe UTF-8 terminals become widely available.
11422
11423 =item 11)
11424
11425 When an install fails for some reason and then I correct the error
11426 condition and retry, CPAN.pm refuses to install the module, saying
11427 C<Already tried without success>.
11428
11429 Use the force pragma like so
11430
11431   force install Foo::Bar
11432
11433 Or you can use
11434
11435   look Foo::Bar
11436
11437 and then 'make install' directly in the subshell.
11438
11439 =item 12)
11440
11441 How do I install a "DEVELOPER RELEASE" of a module?
11442
11443 By default, CPAN will install the latest non-developer release of a
11444 module. If you want to install a dev release, you have to specify the
11445 partial path starting with the author id to the tarball you wish to
11446 install, like so:
11447
11448     cpan> install KWILLIAMS/Module-Build-0.27_07.tar.gz
11449
11450 Note that you can use the C<ls> command to get this path listed.
11451
11452 =item 13)
11453
11454 How do I install a module and all its dependencies from the commandline,
11455 without being prompted for anything, despite my CPAN configuration
11456 (or lack thereof)?
11457
11458 CPAN uses ExtUtils::MakeMaker's prompt() function to ask its questions, so
11459 if you set the PERL_MM_USE_DEFAULT environment variable, you shouldn't be
11460 asked any questions at all (assuming the modules you are installing are
11461 nice about obeying that variable as well):
11462
11463     % PERL_MM_USE_DEFAULT=1 perl -MCPAN -e 'install My::Module'
11464
11465 =item 14)
11466
11467 How do I create a Module::Build based Build.PL derived from an
11468 ExtUtils::MakeMaker focused Makefile.PL?
11469
11470 http://search.cpan.org/search?query=Module::Build::Convert
11471
11472 http://accognoscere.org/papers/perl-module-build-convert/module-build-convert.html
11473
11474 =item 15)
11475
11476 What's the best CPAN site for me?
11477
11478 The urllist config parameter is yours. You can add and remove sites at
11479 will. You should find out which sites have the best uptodateness,
11480 bandwidth, reliability, etc. and are topologically close to you. Some
11481 people prefer fast downloads, others uptodateness, others reliability.
11482 You decide which to try in which order.
11483
11484 Henk P. Penning maintains a site that collects data about CPAN sites:
11485
11486   http://www.cs.uu.nl/people/henkp/mirmon/cpan.html
11487
11488 =back
11489
11490 =head1 COMPATIBILITY
11491
11492 =head2 OLD PERL VERSIONS
11493
11494 CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted
11495 newer versions. It is getting more and more difficult to get the
11496 minimal prerequisites working on older perls. It is close to
11497 impossible to get the whole Bundle::CPAN working there. If you're in
11498 the position to have only these old versions, be advised that CPAN is
11499 designed to work fine without the Bundle::CPAN installed.
11500
11501 To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is
11502 compatible with ancient perls and that File::Temp is listed as a
11503 prerequisite but CPAN has reasonable workarounds if it is missing.
11504
11505 =head2 CPANPLUS
11506
11507 This module and its competitor, the CPANPLUS module, are both much
11508 cooler than the other. CPAN.pm is older. CPANPLUS was designed to be
11509 more modular but it was never tried to make it compatible with CPAN.pm.
11510
11511 =head1 SECURITY ADVICE
11512
11513 This software enables you to upgrade software on your computer and so
11514 is inherently dangerous because the newly installed software may
11515 contain bugs and may alter the way your computer works or even make it
11516 unusable. Please consider backing up your data before every upgrade.
11517
11518 =head1 BUGS
11519
11520 Please report bugs via http://rt.cpan.org/
11521
11522 Before submitting a bug, please make sure that the traditional method
11523 of building a Perl module package from a shell by following the
11524 installation instructions of that package still works in your
11525 environment.
11526
11527 =head1 AUTHOR
11528
11529 Andreas Koenig C<< <andk@cpan.org> >>
11530
11531 =head1 LICENSE
11532
11533 This program is free software; you can redistribute it and/or
11534 modify it under the same terms as Perl itself.
11535
11536 See L<http://www.perl.com/perl/misc/Artistic.html>
11537
11538 =head1 TRANSLATIONS
11539
11540 Kawai,Takanori provides a Japanese translation of this manpage at
11541 http://homepage3.nifty.com/hippo2000/perltips/CPAN.htm
11542
11543 =head1 SEE ALSO
11544
11545 cpan(1), CPAN::Nox(3pm), CPAN::Version(3pm)
11546
11547 =cut
11548
11549