lib/CPAN.pm

   1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
   2 use strict;
   3 package CPAN;
   4 $CPAN::VERSION = '1.88_73';
   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
3338         while (
3339                @{$fullstats->{history}} > 999
3340                || $time - $fullstats->{history}[0]{start} > 30*86400  # one month
3341               ) {
3342             shift @{$fullstats->{history}}
3343         }
3344         push @debug, scalar @{$fullstats->{history}} if $sdebug;
3345         push @debug, time if $sdebug;
3346         push @debug, scalar localtime($fullstats->{history}[0]{start}) if $sdebug;
3347         # need no eval because if this fails, it is serious
3348         my $sfile = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3349         CPAN->_yaml_dumpfile("$sfile.$$",$fullstats);
3350         if ( $sdebug||$CPAN::DEBUG ) {
3351             local $CPAN::DEBUG = 512; # FTP
3352             push @debug, time;
3353             CPAN->debug(sprintf("DEBUG history: before_read[%d]before[%d]at[%d]".
3354                                 "after[%d]at[%d]oldest[%s]dumped backat[%d]",
3355                                 @debug,
3356                                ));
3357         }
3358         # Win32 cannot rename a file to an existing filename
3359         unlink($sfile) if ($^O eq 'MSWin32');
3360         rename "$sfile.$$", $sfile
3361             or $CPAN::Frontend->mydie("Could not rename '$sfile.$$' to '$sfile': $!\n");
3362     }
3363 }
3364
3365 # if file is CHECKSUMS, suggest the place where we got the file to be
3366 # checked from, maybe only for young files?
3367 #-> sub CPAN::FTP::_recommend_url_for
3368 sub _recommend_url_for {
3369     my($self, $file) = @_;
3370     my $urllist = $self->_get_urllist;
3371     if ($file =~ s|/CHECKSUMS(.gz)?$||) {
3372         my $fullstats = $self->_ftp_statistics();
3373         my $history = $fullstats->{history} || [];
3374         while (my $last = pop @$history) {
3375             last if $last->{end} - time > 3600; # only young results are interesting
3376             next unless $last->{file}; # dirname of nothing dies!
3377             next unless $file eq File::Basename::dirname($last->{file});
3378             return $last->{thesiteurl};
3379         }
3380     }
3381     if ($CPAN::Config->{randomize_urllist}
3382         &&
3383         rand(1) < $CPAN::Config->{randomize_urllist}
3384        ) {
3385         $urllist->[int rand scalar @$urllist];
3386     } else {
3387         return ();
3388     }
3389 }
3390
3391 #-> sub CPAN::FTP::_get_urllist
3392 sub _get_urllist {
3393     my($self) = @_;
3394     $CPAN::Config->{urllist} ||= [];
3395     unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
3396         $CPAN::Frontend->mywarn("Malformed urllist; ignoring.  Configuration file corrupt?\n");
3397         $CPAN::Config->{urllist} = [];
3398     }
3399     my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}};
3400     for my $u (@urllist) {
3401         CPAN->debug("u[$u]") if $CPAN::DEBUG;
3402         if (UNIVERSAL::can($u,"text")) {
3403             $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
3404         } else {
3405             $u .= "/" unless substr($u,-1) eq "/";
3406             $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
3407         }
3408     }
3409     \@urllist;
3410 }
3411
3412 #-> sub CPAN::FTP::ftp_get ;
3413 sub ftp_get {
3414     my($class,$host,$dir,$file,$target) = @_;
3415     $class->debug(
3416                   qq[Going to fetch file [$file] from dir [$dir]
3417         on host [$host] as local [$target]\n]
3418                  ) if $CPAN::DEBUG;
3419     my $ftp = Net::FTP->new($host);
3420     unless ($ftp) {
3421         $CPAN::Frontend->mywarn("  Could not connect to host '$host' with Net::FTP\n");
3422         return;
3423     }
3424     return 0 unless defined $ftp;
3425     $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
3426     $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
3427     unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
3428         my $msg = $ftp->message;
3429         $CPAN::Frontend->mywarn("  Couldn't login on $host: $msg");
3430         return;
3431     }
3432     unless ( $ftp->cwd($dir) ){
3433         my $msg = $ftp->message;
3434         $CPAN::Frontend->mywarn("  Couldn't cwd $dir: $msg");
3435         return;
3436     }
3437     $ftp->binary;
3438     $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
3439     unless ( $ftp->get($file,$target) ){
3440         my $msg = $ftp->message;
3441         $CPAN::Frontend->mywarn("  Couldn't fetch $file from $host: $msg");
3442         return;
3443     }
3444     $ftp->quit; # it's ok if this fails
3445     return 1;
3446 }
3447
3448 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
3449
3450  # > *** /install/perl/live/lib/CPAN.pm-        Wed Sep 24 13:08:48 1997
3451  # > --- /tmp/cp        Wed Sep 24 13:26:40 1997
3452  # > ***************
3453  # > *** 1562,1567 ****
3454  # > --- 1562,1580 ----
3455  # >       return 1 if substr($url,0,4) eq "file";
3456  # >       return 1 unless $url =~ m|://([^/]+)|;
3457  # >       my $host = $1;
3458  # > +     my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
3459  # > +     if ($proxy) {
3460  # > +         $proxy =~ m|://([^/:]+)|;
3461  # > +         $proxy = $1;
3462  # > +         my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
3463  # > +         if ($noproxy) {
3464  # > +             if ($host !~ /$noproxy$/) {
3465  # > +                 $host = $proxy;
3466  # > +             }
3467  # > +         } else {
3468  # > +             $host = $proxy;
3469  # > +         }
3470  # > +     }
3471  # >       require Net::Ping;
3472  # >       return 1 unless $Net::Ping::VERSION >= 2;
3473  # >       my $p;
3474
3475
3476 #-> sub CPAN::FTP::localize ;
3477 sub localize {
3478     my($self,$file,$aslocal,$force) = @_;
3479     $force ||= 0;
3480     Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
3481         unless defined $aslocal;
3482     $self->debug("file[$file] aslocal[$aslocal] force[$force]")
3483         if $CPAN::DEBUG;
3484
3485     if ($^O eq 'MacOS') {
3486         # Comment by AK on 2000-09-03: Uniq short filenames would be
3487         # available in CHECKSUMS file
3488         my($name, $path) = File::Basename::fileparse($aslocal, '');
3489         if (length($name) > 31) {
3490             $name =~ s/(
3491                         \.(
3492                            readme(\.(gz|Z))? |
3493                            (tar\.)?(gz|Z) |
3494                            tgz |
3495                            zip |
3496                            pm\.(gz|Z)
3497                           )
3498                        )$//x;
3499             my $suf = $1;
3500             my $size = 31 - length($suf);
3501             while (length($name) > $size) {
3502                 chop $name;
3503             }
3504             $name .= $suf;
3505             $aslocal = File::Spec->catfile($path, $name);
3506         }
3507     }
3508
3509     if (-f $aslocal && -r _ && !($force & 1)){
3510         my $size;
3511         if ($size = -s $aslocal) {
3512             $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
3513             return $aslocal;
3514         } else {
3515             # empty file from a previous unsuccessful attempt to download it
3516             unlink $aslocal or
3517                 $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
3518                                        "could not remove.");
3519         }
3520     }
3521     my($maybe_restore) = 0;
3522     if (-f $aslocal){
3523         rename $aslocal, "$aslocal.bak$$";
3524         $maybe_restore++;
3525     }
3526
3527     my($aslocal_dir) = File::Basename::dirname($aslocal);
3528     File::Path::mkpath($aslocal_dir);
3529     $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
3530         qq{directory "$aslocal_dir".
3531     I\'ll continue, but if you encounter problems, they may be due
3532     to insufficient permissions.\n}) unless -w $aslocal_dir;
3533
3534     # Inheritance is not easier to manage than a few if/else branches
3535     if ($CPAN::META->has_usable('LWP::UserAgent')) {
3536         unless ($Ua) {
3537             CPAN::LWP::UserAgent->config;
3538             eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
3539             if ($@) {
3540                 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
3541                     if $CPAN::DEBUG;
3542             } else {
3543                 my($var);
3544                 $Ua->proxy('ftp',  $var)
3545                     if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
3546                 $Ua->proxy('http', $var)
3547                     if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
3548
3549
3550 # >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
3551 #
3552 #  > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
3553 #  > use ones that require basic autorization.
3554 #
3555 #  > Example of when I use it manually in my own stuff:
3556 #
3557 #  > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
3558 #  > $req->proxy_authorization_basic("username","password");
3559 #  > $res = $ua->request($req);
3560 #
3561
3562                 $Ua->no_proxy($var)
3563                     if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
3564             }
3565         }
3566     }
3567     for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
3568         $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
3569     }
3570
3571     # Try the list of urls for each single object. We keep a record
3572     # where we did get a file from
3573     my(@reordered,$last);
3574     my $ccurllist = $self->_get_urllist;
3575     $last = $#$ccurllist;
3576     if ($force & 2) { # local cpans probably out of date, don't reorder
3577         @reordered = (0..$last);
3578     } else {
3579         @reordered =
3580             sort {
3581                 (substr($ccurllist->[$b],0,4) eq "file")
3582                     <=>
3583                 (substr($ccurllist->[$a],0,4) eq "file")
3584                     or
3585                 defined($ThesiteURL)
3586                     and
3587                 ($ccurllist->[$b] eq $ThesiteURL)
3588                     <=>
3589                 ($ccurllist->[$a] eq $ThesiteURL)
3590             } 0..$last;
3591     }
3592     my(@levels);
3593     $Themethod ||= "";
3594     $self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG;
3595     if ($Themethod) {
3596         @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
3597     } else {
3598         @levels = qw/easy hard hardest/;
3599     }
3600     @levels = qw/easy/ if $^O eq 'MacOS';
3601     my($levelno);
3602     local $ENV{FTP_PASSIVE} =
3603         exists $CPAN::Config->{ftp_passive} ?
3604         $CPAN::Config->{ftp_passive} : 1;
3605     my $ret;
3606     my $stats = $self->_new_stats($file);
3607   LEVEL: for $levelno (0..$#levels) {
3608         my $level = $levels[$levelno];
3609         my $method = "host$level";
3610         my @host_seq = $level eq "easy" ?
3611             @reordered : 0..$last;  # reordered has CDROM up front
3612         my @urllist = map { $ccurllist->[$_] } @host_seq;
3613         for my $u (@CPAN::Defaultsites) {
3614             push @urllist, $u unless grep { $_ eq $u } @urllist;
3615         }
3616         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
3617         my $aslocal_tempfile = $aslocal . ".tmp" . $$;
3618         if (my $recommend = $self->_recommend_url_for($file)) {
3619             @urllist = grep { $_ ne $recommend } @urllist;
3620             unshift @urllist, $recommend;
3621         }
3622         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
3623         $ret = $self->$method(\@urllist,$file,$aslocal_tempfile,$stats);
3624         if ($ret) {
3625             CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG;
3626             if ($ret eq $aslocal_tempfile) {
3627                 # if we got it exactly as we asked for, only then we
3628                 # want to rename
3629                 rename $aslocal_tempfile, $aslocal
3630                     or $CPAN::Frontend->mydie("Error while trying to rename ".
3631                                               "'$ret' to '$aslocal': $!");
3632                 $ret = $aslocal;
3633             }
3634             $Themethod = $level;
3635             my $now = time;
3636             # utime $now, $now, $aslocal; # too bad, if we do that, we
3637                                           # might alter a local mirror
3638             $self->debug("level[$level]") if $CPAN::DEBUG;
3639             last LEVEL;
3640         } else {
3641             unlink $aslocal_tempfile;
3642             last if $CPAN::Signal; # need to cleanup
3643         }
3644     }
3645     if ($ret) {
3646         $stats->{filesize} = -s $ret;
3647     }
3648     $self->debug("before _add_to_statistics") if $CPAN::DEBUG;
3649     $self->_add_to_statistics($stats);
3650     $self->debug("after _add_to_statistics") if $CPAN::DEBUG;
3651     if ($ret) {
3652         unlink "$aslocal.bak$$";
3653         return $ret;
3654     }
3655     unless ($CPAN::Signal) {
3656         my(@mess);
3657         local $" = " ";
3658         if (@{$CPAN::Config->{urllist}}) {
3659             push @mess,
3660                 qq{Please check, if the URLs I found in your configuration file \(}.
3661                     join(", ", @{$CPAN::Config->{urllist}}).
3662                         qq{\) are valid.};
3663         } else {
3664             push @mess, qq{Your urllist is empty!};
3665         }
3666         push @mess, qq{The urllist can be edited.},
3667             qq{E.g. with 'o conf urllist push ftp://myurl/'};
3668         $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
3669         $CPAN::Frontend->mywarn("Could not fetch $file\n");
3670         $CPAN::Frontend->mysleep(2);
3671     }
3672     if ($maybe_restore) {
3673         rename "$aslocal.bak$$", $aslocal;
3674         $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
3675                                  $self->ls($aslocal));
3676         return $aslocal;
3677     }
3678     return;
3679 }
3680
3681 sub _set_attempt {
3682     my($self,$stats,$method,$url) = @_;
3683     push @{$stats->{attempts}}, {
3684                                  method => $method,
3685                                  start => _mytime,
3686                                  url => $url,
3687                                 };
3688 }
3689
3690 # package CPAN::FTP;
3691 sub hosteasy {
3692     my($self,$host_seq,$file,$aslocal,$stats) = @_;
3693     my($ro_url);
3694   HOSTEASY: for $ro_url (@$host_seq) {
3695         $self->_set_attempt($stats,"easy",$ro_url);
3696         my $url .= "$ro_url$file";
3697         $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
3698         if ($url =~ /^file:/) {
3699             my $l;
3700             if ($CPAN::META->has_inst('URI::URL')) {
3701                 my $u =  URI::URL->new($url);
3702                 $l = $u->path;
3703             } else { # works only on Unix, is poorly constructed, but
3704                 # hopefully better than nothing.
3705                 # RFC 1738 says fileurl BNF is
3706                 # fileurl = "file://" [ host | "localhost" ] "/" fpath
3707                 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
3708                 # the code
3709                 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
3710                 $l =~ s|^file:||;                   # assume they
3711                                                     # meant
3712                                                     # file://localhost
3713                 $l =~ s|^/||s
3714                     if ! -f $l && $l =~ m|^/\w:|;   # e.g. /P:
3715             }
3716             $self->debug("local file[$l]") if $CPAN::DEBUG;
3717             if ( -f $l && -r _) {
3718                 $ThesiteURL = $ro_url;
3719                 return $l;
3720             }
3721             if ($l =~ /(.+)\.gz$/) {
3722                 my $ungz = $1;
3723                 if ( -f $ungz && -r _) {
3724                     $ThesiteURL = $ro_url;
3725                     return $ungz;
3726                 }
3727             }
3728             # Maybe mirror has compressed it?
3729             if (-f "$l.gz") {
3730                 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
3731                 eval { CPAN::Tarzip->new("$l.gz")->gunzip($aslocal) };
3732                 if ( -f $aslocal) {
3733                     $ThesiteURL = $ro_url;
3734                     return $aslocal;
3735                 }
3736             }
3737         }
3738         $self->debug("it was not a file URL") if $CPAN::DEBUG;
3739         if ($CPAN::META->has_usable('LWP')) {
3740             $CPAN::Frontend->myprint("Fetching with LWP:
3741   $url
3742 ");
3743             unless ($Ua) {
3744                 CPAN::LWP::UserAgent->config;
3745                 eval { $Ua = CPAN::LWP::UserAgent->new; };
3746                 if ($@) {
3747                     $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
3748                 }
3749             }
3750             my $res = $Ua->mirror($url, $aslocal);
3751             if ($res->is_success) {
3752                 $ThesiteURL = $ro_url;
3753                 my $now = time;
3754                 utime $now, $now, $aslocal; # download time is more
3755                                             # important than upload
3756                                             # time
3757                 return $aslocal;
3758             } elsif ($url !~ /\.gz(?!\n)\Z/) {
3759                 my $gzurl = "$url.gz";
3760                 $CPAN::Frontend->myprint("Fetching with LWP:
3761   $gzurl
3762 ");
3763                 $res = $Ua->mirror($gzurl, "$aslocal.gz");
3764                 if ($res->is_success) {
3765                     if (eval {CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)}) {
3766                         $ThesiteURL = $ro_url;
3767                         return $aslocal;
3768                     }
3769                 }
3770             } else {
3771                 $CPAN::Frontend->myprint(sprintf(
3772                                                  "LWP failed with code[%s] message[%s]\n",
3773                                                  $res->code,
3774                                                  $res->message,
3775                                                 ));
3776                 # Alan Burlison informed me that in firewall environments
3777                 # Net::FTP can still succeed where LWP fails. So we do not
3778                 # skip Net::FTP anymore when LWP is available.
3779             }
3780         } else {
3781             $CPAN::Frontend->mywarn("  LWP not available\n");
3782         }
3783         return if $CPAN::Signal;
3784         if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3785             # that's the nice and easy way thanks to Graham
3786             $self->debug("recognized ftp") if $CPAN::DEBUG;
3787             my($host,$dir,$getfile) = ($1,$2,$3);
3788             if ($CPAN::META->has_usable('Net::FTP')) {
3789                 $dir =~ s|/+|/|g;
3790                 $CPAN::Frontend->myprint("Fetching with Net::FTP:
3791   $url
3792 ");
3793                 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
3794                              "aslocal[$aslocal]") if $CPAN::DEBUG;
3795                 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
3796                     $ThesiteURL = $ro_url;
3797                     return $aslocal;
3798                 }
3799                 if ($aslocal !~ /\.gz(?!\n)\Z/) {
3800                     my $gz = "$aslocal.gz";
3801                     $CPAN::Frontend->myprint("Fetching with Net::FTP
3802   $url.gz
3803 ");
3804                     if (CPAN::FTP->ftp_get($host,
3805                                            $dir,
3806                                            "$getfile.gz",
3807                                            $gz) &&
3808                         eval{CPAN::Tarzip->new($gz)->gunzip($aslocal)}
3809                        ){
3810                         $ThesiteURL = $ro_url;
3811                         return $aslocal;
3812                     }
3813                 }
3814                 # next HOSTEASY;
3815             } else {
3816                 CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG;
3817             }
3818         }
3819         if (
3820             UNIVERSAL::can($ro_url,"text")
3821             and
3822             $ro_url->{FROM} eq "USER"
3823            ){
3824             ##address #17973: default URLs should not try to override
3825             ##user-defined URLs just because LWP is not available
3826             my $ret = $self->hosthard([$ro_url],$file,$aslocal,$stats);
3827             return $ret if $ret;
3828         }
3829         return if $CPAN::Signal;
3830     }
3831 }
3832
3833 # package CPAN::FTP;
3834 sub hosthard {
3835   my($self,$host_seq,$file,$aslocal,$stats) = @_;
3836
3837   # Came back if Net::FTP couldn't establish connection (or
3838   # failed otherwise) Maybe they are behind a firewall, but they
3839   # gave us a socksified (or other) ftp program...
3840
3841   my($ro_url);
3842   my($devnull) = $CPAN::Config->{devnull} || "";
3843   # < /dev/null ";
3844   my($aslocal_dir) = File::Basename::dirname($aslocal);
3845   File::Path::mkpath($aslocal_dir);
3846   HOSTHARD: for $ro_url (@$host_seq) {
3847         $self->_set_attempt($stats,"hard",$ro_url);
3848         my $url = "$ro_url$file";
3849         my($proto,$host,$dir,$getfile);
3850
3851         # Courtesy Mark Conty mark_conty@cargill.com change from
3852         # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3853         # to
3854         if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
3855           # proto not yet used
3856           ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
3857         } else {
3858           next HOSTHARD; # who said, we could ftp anything except ftp?
3859         }
3860         next HOSTHARD if $proto eq "file"; # file URLs would have had
3861                                            # success above. Likely a bogus URL
3862
3863         $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
3864
3865         # Try the most capable first and leave ncftp* for last as it only
3866         # does FTP.
3867       DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
3868           my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
3869           next unless defined $funkyftp;
3870           next if $funkyftp =~ /^\s*$/;
3871
3872           my($asl_ungz, $asl_gz);
3873           ($asl_ungz = $aslocal) =~ s/\.gz//;
3874           $asl_gz = "$asl_ungz.gz";
3875
3876           my($src_switch) = "";
3877           my($chdir) = "";
3878           my($stdout_redir) = " > $asl_ungz";
3879           if ($f eq "lynx"){
3880             $src_switch = " -source";
3881           } elsif ($f eq "ncftp"){
3882             $src_switch = " -c";
3883           } elsif ($f eq "wget"){
3884             $src_switch = " -O $asl_ungz";
3885             $stdout_redir = "";
3886           } elsif ($f eq 'curl'){
3887             $src_switch = ' -L -f -s -S --netrc-optional';
3888           }
3889
3890           if ($f eq "ncftpget"){
3891             $chdir = "cd $aslocal_dir && ";
3892             $stdout_redir = "";
3893           }
3894           $CPAN::Frontend->myprint(
3895                                    qq[
3896 Trying with "$funkyftp$src_switch" to get
3897     $url
3898 ]);
3899           my($system) =
3900               "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
3901           $self->debug("system[$system]") if $CPAN::DEBUG;
3902           my($wstatus) = system($system);
3903           if ($f eq "lynx") {
3904               # lynx returns 0 when it fails somewhere
3905               if (-s $asl_ungz) {
3906                   my $content = do { local *FH;
3907                                      open FH, $asl_ungz or die;
3908                                      local $/;
3909                                      <FH> };
3910                   if ($content =~ /^<.*(<title>[45]|Error [45])/si) {
3911                       $CPAN::Frontend->mywarn(qq{
3912 No success, the file that lynx has has downloaded looks like an error message:
3913 $content
3914 });
3915                       $CPAN::Frontend->mysleep(1);
3916                       next DLPRG;
3917                   }
3918               } else {
3919                   $CPAN::Frontend->myprint(qq{
3920 No success, the file that lynx has has downloaded is an empty file.
3921 });
3922                   next DLPRG;
3923               }
3924           }
3925           if ($wstatus == 0) {
3926             if (-s $aslocal) {
3927               # Looks good
3928             } elsif ($asl_ungz ne $aslocal) {
3929               # test gzip integrity
3930               if (eval{CPAN::Tarzip->new($asl_ungz)->gtest}) {
3931                   # e.g. foo.tar is gzipped --> foo.tar.gz
3932                   rename $asl_ungz, $aslocal;
3933               } else {
3934                   eval{CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz)};
3935               }
3936             }
3937             $ThesiteURL = $ro_url;
3938             return $aslocal;
3939           } elsif ($url !~ /\.gz(?!\n)\Z/) {
3940             unlink $asl_ungz if
3941                 -f $asl_ungz && -s _ == 0;
3942             my $gz = "$aslocal.gz";
3943             my $gzurl = "$url.gz";
3944             $CPAN::Frontend->myprint(
3945                                      qq[
3946 Trying with "$funkyftp$src_switch" to get
3947   $url.gz
3948 ]);
3949             my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
3950             $self->debug("system[$system]") if $CPAN::DEBUG;
3951             my($wstatus);
3952             if (($wstatus = system($system)) == 0
3953                 &&
3954                 -s $asl_gz
3955                ) {
3956               # test gzip integrity
3957                 my $ct = eval{CPAN::Tarzip->new($asl_gz)};
3958                 if ($ct && $ct->gtest) {
3959                     $ct->gunzip($aslocal);
3960                 } else {
3961                     # somebody uncompressed file for us?
3962                     rename $asl_ungz, $aslocal;
3963                 }
3964                 $ThesiteURL = $ro_url;
3965                 return $aslocal;
3966             } else {
3967               unlink $asl_gz if -f $asl_gz;
3968             }
3969           } else {
3970             my $estatus = $wstatus >> 8;
3971             my $size = -f $aslocal ?
3972                 ", left\n$aslocal with size ".-s _ :
3973                     "\nWarning: expected file [$aslocal] doesn't exist";
3974             $CPAN::Frontend->myprint(qq{
3975 System call "$system"
3976 returned status $estatus (wstat $wstatus)$size
3977 });
3978           }
3979           return if $CPAN::Signal;
3980         } # transfer programs
3981     } # host
3982 }
3983
3984 # package CPAN::FTP;
3985 sub hosthardest {
3986     my($self,$host_seq,$file,$aslocal,$stats) = @_;
3987
3988     my($ro_url);
3989     my($aslocal_dir) = File::Basename::dirname($aslocal);
3990     File::Path::mkpath($aslocal_dir);
3991     my $ftpbin = $CPAN::Config->{ftp};
3992     unless ($ftpbin && length $ftpbin && MM->maybe_command($ftpbin)) {
3993         $CPAN::Frontend->myprint("No external ftp command available\n\n");
3994         return;
3995     }
3996     $CPAN::Frontend->mywarn(qq{
3997 As a last ressort we now switch to the external ftp command '$ftpbin'
3998 to get '$aslocal'.
3999
4000 Doing so often leads to problems that are hard to diagnose.
4001
4002 If you're victim of such problems, please consider unsetting the ftp
4003 config variable with
4004
4005     o conf ftp ""
4006     o conf commit
4007
4008 });
4009     $CPAN::Frontend->mysleep(2);
4010   HOSTHARDEST: for $ro_url (@$host_seq) {
4011         $self->_set_attempt($stats,"hardest",$ro_url);
4012         my $url = "$ro_url$file";
4013         $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
4014         unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
4015             next;
4016         }
4017         my($host,$dir,$getfile) = ($1,$2,$3);
4018         my $timestamp = 0;
4019         my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
4020            $ctime,$blksize,$blocks) = stat($aslocal);
4021         $timestamp = $mtime ||= 0;
4022         my($netrc) = CPAN::FTP::netrc->new;
4023         my($netrcfile) = $netrc->netrc;
4024         my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
4025         my $targetfile = File::Basename::basename($aslocal);
4026         my(@dialog);
4027         push(
4028              @dialog,
4029              "lcd $aslocal_dir",
4030              "cd /",
4031              map("cd $_", split /\//, $dir), # RFC 1738
4032              "bin",
4033              "get $getfile $targetfile",
4034              "quit"
4035             );
4036         if (! $netrcfile) {
4037             CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
4038         } elsif ($netrc->hasdefault || $netrc->contains($host)) {
4039             CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
4040                                 $netrc->hasdefault,
4041                                 $netrc->contains($host))) if $CPAN::DEBUG;
4042             if ($netrc->protected) {
4043                 my $dialog = join "", map { "    $_\n" } @dialog;
4044                 my $netrc_explain;
4045                 if ($netrc->contains($host)) {
4046                     $netrc_explain = "Relying that your .netrc entry for '$host' ".
4047                         "manages the login";
4048                 } else {
4049                     $netrc_explain = "Relying that your default .netrc entry ".
4050                         "manages the login";
4051                 }
4052                 $CPAN::Frontend->myprint(qq{
4053   Trying with external ftp to get
4054     $url
4055   $netrc_explain
4056   Going to send the dialog
4057 $dialog
4058 }
4059                      );
4060                 $self->talk_ftp("$ftpbin$verbose $host",
4061                                 @dialog);
4062                 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4063                  $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
4064                 $mtime ||= 0;
4065                 if ($mtime > $timestamp) {
4066                     $CPAN::Frontend->myprint("GOT $aslocal\n");
4067                     $ThesiteURL = $ro_url;
4068                     return $aslocal;
4069                 } else {
4070                     $CPAN::Frontend->myprint("Hmm... Still failed!\n");
4071                 }
4072                 return if $CPAN::Signal;
4073             } else {
4074                 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
4075                                         qq{correctly protected.\n});
4076             }
4077         } else {
4078             $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
4079   nor does it have a default entry\n");
4080         }
4081
4082         # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
4083         # then and login manually to host, using e-mail as
4084         # password.
4085         $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
4086         unshift(
4087                 @dialog,
4088                 "open $host",
4089                 "user anonymous $Config::Config{'cf_email'}"
4090                );
4091         my $dialog = join "", map { "    $_\n" } @dialog;
4092         $CPAN::Frontend->myprint(qq{
4093   Trying with external ftp to get
4094     $url
4095   Going to send the dialog
4096 $dialog
4097 }
4098                      );
4099         $self->talk_ftp("$ftpbin$verbose -n", @dialog);
4100         ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4101          $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
4102         $mtime ||= 0;
4103         if ($mtime > $timestamp) {
4104             $CPAN::Frontend->myprint("GOT $aslocal\n");
4105             $ThesiteURL = $ro_url;
4106             return $aslocal;
4107         } else {
4108             $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
4109         }
4110         return if $CPAN::Signal;
4111         $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
4112         $CPAN::Frontend->mysleep(2);
4113     } # host
4114 }
4115
4116 # package CPAN::FTP;
4117 sub talk_ftp {
4118     my($self,$command,@dialog) = @_;
4119     my $fh = FileHandle->new;
4120     $fh->open("|$command") or die "Couldn't open ftp: $!";
4121     foreach (@dialog) { $fh->print("$_\n") }
4122     $fh->close;         # Wait for process to complete
4123     my $wstatus = $?;
4124     my $estatus = $wstatus >> 8;
4125     $CPAN::Frontend->myprint(qq{
4126 Subprocess "|$command"
4127   returned status $estatus (wstat $wstatus)
4128 }) if $wstatus;
4129 }
4130
4131 # find2perl needs modularization, too, all the following is stolen
4132 # from there
4133 # CPAN::FTP::ls
4134 sub ls {
4135     my($self,$name) = @_;
4136     my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
4137      $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
4138
4139     my($perms,%user,%group);
4140     my $pname = $name;
4141
4142     if ($blocks) {
4143         $blocks = int(($blocks + 1) / 2);
4144     }
4145     else {
4146         $blocks = int(($sizemm + 1023) / 1024);
4147     }
4148
4149     if    (-f _) { $perms = '-'; }
4150     elsif (-d _) { $perms = 'd'; }
4151     elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
4152     elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
4153     elsif (-p _) { $perms = 'p'; }
4154     elsif (-S _) { $perms = 's'; }
4155     else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
4156
4157     my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
4158     my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
4159     my $tmpmode = $mode;
4160     my $tmp = $rwx[$tmpmode & 7];
4161     $tmpmode >>= 3;
4162     $tmp = $rwx[$tmpmode & 7] . $tmp;
4163     $tmpmode >>= 3;
4164     $tmp = $rwx[$tmpmode & 7] . $tmp;
4165     substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
4166     substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
4167     substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
4168     $perms .= $tmp;
4169
4170     my $user = $user{$uid} || $uid;   # too lazy to implement lookup
4171     my $group = $group{$gid} || $gid;
4172
4173     my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
4174     my($timeyear);
4175     my($moname) = $moname[$mon];
4176     if (-M _ > 365.25 / 2) {
4177         $timeyear = $year + 1900;
4178     }
4179     else {
4180         $timeyear = sprintf("%02d:%02d", $hour, $min);
4181     }
4182
4183     sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
4184             $ino,
4185                  $blocks,
4186                       $perms,
4187                             $nlink,
4188                                 $user,
4189                                      $group,
4190                                           $sizemm,
4191                                               $moname,
4192                                                  $mday,
4193                                                      $timeyear,
4194                                                          $pname;
4195 }
4196
4197 package CPAN::FTP::netrc;
4198 use strict;
4199
4200 # package CPAN::FTP::netrc;
4201 sub new {
4202     my($class) = @_;
4203     my $home = CPAN::HandleConfig::home;
4204     my $file = File::Spec->catfile($home,".netrc");
4205
4206     my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4207        $atime,$mtime,$ctime,$blksize,$blocks)
4208         = stat($file);
4209     $mode ||= 0;
4210     my $protected = 0;
4211
4212     my($fh,@machines,$hasdefault);
4213     $hasdefault = 0;
4214     $fh = FileHandle->new or die "Could not create a filehandle";
4215
4216     if($fh->open($file)){
4217         $protected = ($mode & 077) == 0;
4218         local($/) = "";
4219       NETRC: while (<$fh>) {
4220             my(@tokens) = split " ", $_;
4221           TOKEN: while (@tokens) {
4222                 my($t) = shift @tokens;
4223                 if ($t eq "default"){
4224                     $hasdefault++;
4225                     last NETRC;
4226                 }
4227                 last TOKEN if $t eq "macdef";
4228                 if ($t eq "machine") {
4229                     push @machines, shift @tokens;
4230                 }
4231             }
4232         }
4233     } else {
4234         $file = $hasdefault = $protected = "";
4235     }
4236
4237     bless {
4238            'mach' => [@machines],
4239            'netrc' => $file,
4240            'hasdefault' => $hasdefault,
4241            'protected' => $protected,
4242           }, $class;
4243 }
4244
4245 # CPAN::FTP::netrc::hasdefault;
4246 sub hasdefault { shift->{'hasdefault'} }
4247 sub netrc      { shift->{'netrc'}      }
4248 sub protected  { shift->{'protected'}  }
4249 sub contains {
4250     my($self,$mach) = @_;
4251     for ( @{$self->{'mach'}} ) {
4252         return 1 if $_ eq $mach;
4253     }
4254     return 0;
4255 }
4256
4257 package CPAN::Complete;
4258 use strict;
4259
4260 sub gnu_cpl {
4261     my($text, $line, $start, $end) = @_;
4262     my(@perlret) = cpl($text, $line, $start);
4263     # find longest common match. Can anybody show me how to peruse
4264     # T::R::Gnu to have this done automatically? Seems expensive.
4265     return () unless @perlret;
4266     my($newtext) = $text;
4267     for (my $i = length($text)+1;;$i++) {
4268         last unless length($perlret[0]) && length($perlret[0]) >= $i;
4269         my $try = substr($perlret[0],0,$i);
4270         my @tries = grep {substr($_,0,$i) eq $try} @perlret;
4271         # warn "try[$try]tries[@tries]";
4272         if (@tries == @perlret) {
4273             $newtext = $try;
4274         } else {
4275             last;
4276         }
4277     }
4278     ($newtext,@perlret);
4279 }
4280
4281 #-> sub CPAN::Complete::cpl ;
4282 sub cpl {
4283     my($word,$line,$pos) = @_;
4284     $word ||= "";
4285     $line ||= "";
4286     $pos ||= 0;
4287     CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4288     $line =~ s/^\s*//;
4289     if ($line =~ s/^((?:notest|f?force)\s*)//) {
4290         $pos -= length($1);
4291     }
4292     my @return;
4293     if ($pos == 0) {
4294         @return = grep /^$word/, @CPAN::Complete::COMMANDS;
4295     } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
4296         @return = ();
4297     } elsif ($line =~ /^(a|ls)\s/) {
4298         @return = cplx('CPAN::Author',uc($word));
4299     } elsif ($line =~ /^b\s/) {
4300         CPAN::Shell->local_bundles;
4301         @return = cplx('CPAN::Bundle',$word);
4302     } elsif ($line =~ /^d\s/) {
4303         @return = cplx('CPAN::Distribution',$word);
4304     } elsif ($line =~ m/^(
4305                           [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
4306                          )\s/x ) {
4307         if ($word =~ /^Bundle::/) {
4308             CPAN::Shell->local_bundles;
4309         }
4310         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
4311     } elsif ($line =~ /^i\s/) {
4312         @return = cpl_any($word);
4313     } elsif ($line =~ /^reload\s/) {
4314         @return = cpl_reload($word,$line,$pos);
4315     } elsif ($line =~ /^o\s/) {
4316         @return = cpl_option($word,$line,$pos);
4317     } elsif ($line =~ m/^\S+\s/ ) {
4318         # fallback for future commands and what we have forgotten above
4319         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
4320     } else {
4321         @return = ();
4322     }
4323     return @return;
4324 }
4325
4326 #-> sub CPAN::Complete::cplx ;
4327 sub cplx {
4328     my($class, $word) = @_;
4329     if (CPAN::_sqlite_running) {
4330         $CPAN::SQLite->search($class, "^\Q$word\E");
4331     }
4332     sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
4333 }
4334
4335 #-> sub CPAN::Complete::cpl_any ;
4336 sub cpl_any {
4337     my($word) = shift;
4338     return (
4339             cplx('CPAN::Author',$word),
4340             cplx('CPAN::Bundle',$word),
4341             cplx('CPAN::Distribution',$word),
4342             cplx('CPAN::Module',$word),
4343            );
4344 }
4345
4346 #-> sub CPAN::Complete::cpl_reload ;
4347 sub cpl_reload {
4348     my($word,$line,$pos) = @_;
4349     $word ||= "";
4350     my(@words) = split " ", $line;
4351     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4352     my(@ok) = qw(cpan index);
4353     return @ok if @words == 1;
4354     return grep /^\Q$word\E/, @ok if @words == 2 && $word;
4355 }
4356
4357 #-> sub CPAN::Complete::cpl_option ;
4358 sub cpl_option {
4359     my($word,$line,$pos) = @_;
4360     $word ||= "";
4361     my(@words) = split " ", $line;
4362     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4363     my(@ok) = qw(conf debug);
4364     return @ok if @words == 1;
4365     return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
4366     if (0) {
4367     } elsif ($words[1] eq 'index') {
4368         return ();
4369     } elsif ($words[1] eq 'conf') {
4370         return CPAN::HandleConfig::cpl(@_);
4371     } elsif ($words[1] eq 'debug') {
4372         return sort grep /^\Q$word\E/i,
4373             sort keys %CPAN::DEBUG, 'all';
4374     }
4375 }
4376
4377 package CPAN::Index;
4378 use strict;
4379
4380 #-> sub CPAN::Index::force_reload ;
4381 sub force_reload {
4382     my($class) = @_;
4383     $CPAN::Index::LAST_TIME = 0;
4384     $class->reload(1);
4385 }
4386
4387 #-> sub CPAN::Index::reload ;
4388 sub reload {
4389     my($self,$force) = @_;
4390     my $time = time;
4391
4392     # XXX check if a newer one is available. (We currently read it
4393     # from time to time)
4394     for ($CPAN::Config->{index_expire}) {
4395         $_ = 0.001 unless $_ && $_ > 0.001;
4396     }
4397     unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
4398         # debug here when CPAN doesn't seem to read the Metadata
4399         require Carp;
4400         Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
4401     }
4402     unless ($CPAN::META->{PROTOCOL}) {
4403         $self->read_metadata_cache;
4404         $CPAN::META->{PROTOCOL} ||= "1.0";
4405     }
4406     if ( $CPAN::META->{PROTOCOL} < PROTOCOL  ) {
4407         # warn "Setting last_time to 0";
4408         $LAST_TIME = 0; # No warning necessary
4409     }
4410     if ($LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
4411         and ! $force){
4412         # called too often
4413         # CPAN->debug("LAST_TIME[$LAST_TIME]index_expire[$CPAN::Config->{index_expire}]time[$time]");
4414     } elsif (0) {
4415         # IFF we are developing, it helps to wipe out the memory
4416         # between reloads, otherwise it is not what a user expects.
4417         undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
4418         $CPAN::META = CPAN->new;
4419     } else {
4420         my($debug,$t2);
4421         local $LAST_TIME = $time;
4422         local $CPAN::META->{PROTOCOL} = PROTOCOL;
4423
4424         my $needshort = $^O eq "dos";
4425
4426         $self->rd_authindex($self
4427                           ->reload_x(
4428                                      "authors/01mailrc.txt.gz",
4429                                      $needshort ?
4430                                      File::Spec->catfile('authors', '01mailrc.gz') :
4431                                      File::Spec->catfile('authors', '01mailrc.txt.gz'),
4432                                      $force));
4433         $t2 = time;
4434         $debug = "timing reading 01[".($t2 - $time)."]";
4435         $time = $t2;
4436         return if $CPAN::Signal; # this is sometimes lengthy
4437         $self->rd_modpacks($self
4438                          ->reload_x(
4439                                     "modules/02packages.details.txt.gz",
4440                                     $needshort ?
4441                                     File::Spec->catfile('modules', '02packag.gz') :
4442                                     File::Spec->catfile('modules', '02packages.details.txt.gz'),
4443                                     $force));
4444         $t2 = time;
4445         $debug .= "02[".($t2 - $time)."]";
4446         $time = $t2;
4447         return if $CPAN::Signal; # this is sometimes lengthy
4448         $self->rd_modlist($self
4449                         ->reload_x(
4450                                    "modules/03modlist.data.gz",
4451                                    $needshort ?
4452                                    File::Spec->catfile('modules', '03mlist.gz') :
4453                                    File::Spec->catfile('modules', '03modlist.data.gz'),
4454                                    $force));
4455         $self->write_metadata_cache;
4456         $t2 = time;
4457         $debug .= "03[".($t2 - $time)."]";
4458         $time = $t2;
4459         CPAN->debug($debug) if $CPAN::DEBUG;
4460     }
4461     if ($CPAN::Config->{build_dir_reuse}) {
4462         $self->reanimate_build_dir;
4463     }
4464     if (CPAN::_sqlite_running) {
4465         $CPAN::SQLite->reload(time => $time, force => $force)
4466             if not $LAST_TIME;
4467     }
4468     $LAST_TIME = $time;
4469     $CPAN::META->{PROTOCOL} = PROTOCOL;
4470 }
4471
4472 #-> sub CPAN::Index::reanimate_build_dir ;
4473 sub reanimate_build_dir {
4474     my($self) = @_;
4475     unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module}||"YAML")) {
4476         return;
4477     }
4478     return if $HAVE_REANIMATED++;
4479     my $d = $CPAN::Config->{build_dir};
4480     my $dh = DirHandle->new;
4481     opendir $dh, $d or return; # does not exist
4482     my $dirent;
4483     my $i = 0;
4484     my $painted = 0;
4485     my $restored = 0;
4486     $CPAN::Frontend->myprint("Going to read $CPAN::Config->{build_dir}/\n");
4487     my @candidates = map { $_->[0] }
4488         sort { $b->[1] <=> $a->[1] }
4489             map { [ $_, -M File::Spec->catfile($d,$_) ] }
4490                 grep {/\.yml$/} readdir $dh;
4491   DISTRO: for $dirent (@candidates) {
4492         my $y = eval {CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))};
4493         die $@ if $@;
4494         my $c = $y->[0];
4495         if ($c && CPAN->_perl_fingerprint($c->{perl})) {
4496             my $key = $c->{distribution}{ID};
4497             for my $k (keys %{$c->{distribution}}) {
4498                 if ($c->{distribution}{$k}
4499                     && ref $c->{distribution}{$k}
4500                     && UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) {
4501                     $c->{distribution}{$k}{COMMANDID} = $i - @candidates;
4502                 }
4503             }
4504
4505             #we tried to restore only if element already
4506             #exists; but then we do not work with metadata
4507             #turned off.
4508             my $do
4509                 = $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key}
4510                     = $c->{distribution};
4511             delete $do->{badtestcnt};
4512             # $DB::single = 1;
4513             if ($do->{make_test}
4514                 && $do->{build_dir}
4515                 && !$do->{make_test}->failed
4516                 && (
4517                     !$do->{install}
4518                     ||
4519                     $do->{install}->failed
4520                    )
4521                ) {
4522                 $CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME});
4523             }
4524             $restored++;
4525         }
4526         $i++;
4527         while (($painted/76) < ($i/@candidates)) {
4528             $CPAN::Frontend->myprint(".");
4529             $painted++;
4530         }
4531     }
4532     $CPAN::Frontend->myprint(sprintf(
4533                                      "DONE\nFound %s old builds, restored the state of %s\n",
4534                                      @candidates ? sprintf("%d",scalar @candidates) : "no",
4535                                      $restored || "none",
4536                                     ));
4537 }
4538
4539
4540 #-> sub CPAN::Index::reload_x ;
4541 sub reload_x {
4542     my($cl,$wanted,$localname,$force) = @_;
4543     $force |= 2; # means we're dealing with an index here
4544     CPAN::HandleConfig->load; # we should guarantee loading wherever
4545                               # we rely on Config XXX
4546     $localname ||= $wanted;
4547     my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
4548                                          $localname);
4549     if (
4550         -f $abs_wanted &&
4551         -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
4552         !($force & 1)
4553        ) {
4554         my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
4555         $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
4556                    qq{day$s. I\'ll use that.});
4557         return $abs_wanted;
4558     } else {
4559         $force |= 1; # means we're quite serious about it.
4560     }
4561     return CPAN::FTP->localize($wanted,$abs_wanted,$force);
4562 }
4563
4564 #-> sub CPAN::Index::rd_authindex ;
4565 sub rd_authindex {
4566     my($cl, $index_target) = @_;
4567     return unless defined $index_target;
4568     return if CPAN::_sqlite_running;
4569     my @lines;
4570     $CPAN::Frontend->myprint("Going to read $index_target\n");
4571     local(*FH);
4572     tie *FH, 'CPAN::Tarzip', $index_target;
4573     local($/) = "\n";
4574     local($_);
4575     push @lines, split /\012/ while <FH>;
4576     my $i = 0;
4577     my $painted = 0;
4578     foreach (@lines) {
4579         my($userid,$fullname,$email) =
4580             m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/;
4581         $fullname ||= $email;
4582         if ($userid && $fullname && $email){
4583             my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
4584             $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
4585         } else {
4586             CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG;
4587         }
4588         $i++;
4589         while (($painted/76) < ($i/@lines)) {
4590             $CPAN::Frontend->myprint(".");
4591             $painted++;
4592         }
4593         return if $CPAN::Signal;
4594     }
4595     $CPAN::Frontend->myprint("DONE\n");
4596 }
4597
4598 sub userid {
4599   my($self,$dist) = @_;
4600   $dist = $self->{'id'} unless defined $dist;
4601   my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
4602   $ret;
4603 }
4604
4605 #-> sub CPAN::Index::rd_modpacks ;
4606 sub rd_modpacks {
4607     my($self, $index_target) = @_;
4608     return unless defined $index_target;
4609     return if CPAN::_sqlite_running;
4610     $CPAN::Frontend->myprint("Going to read $index_target\n");
4611     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
4612     local $_;
4613     CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
4614     my $slurp = "";
4615     my $chunk;
4616     while (my $bytes = $fh->READ(\$chunk,8192)) {
4617         $slurp.=$chunk;
4618     }
4619     my @lines = split /\012/, $slurp;
4620     CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
4621     undef $fh;
4622     # read header
4623     my($line_count,$last_updated);
4624     while (@lines) {
4625         my $shift = shift(@lines);
4626         last if $shift =~ /^\s*$/;
4627         $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
4628         $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
4629     }
4630     CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
4631     if (not defined $line_count) {
4632
4633         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
4634 Please check the validity of the index file by comparing it to more
4635 than one CPAN mirror. I'll continue but problems seem likely to
4636 happen.\a
4637 });
4638
4639         $CPAN::Frontend->mysleep(5);
4640     } elsif ($line_count != scalar @lines) {
4641
4642         $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
4643 contains a Line-Count header of %d but I see %d lines there. Please
4644 check the validity of the index file by comparing it to more than one
4645 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
4646 $index_target, $line_count, scalar(@lines));
4647
4648     }
4649     if (not defined $last_updated) {
4650
4651         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
4652 Please check the validity of the index file by comparing it to more
4653 than one CPAN mirror. I'll continue but problems seem likely to
4654 happen.\a
4655 });
4656
4657         $CPAN::Frontend->mysleep(5);
4658     } else {
4659
4660         $CPAN::Frontend
4661             ->myprint(sprintf qq{  Database was generated on %s\n},
4662                       $last_updated);
4663         $DATE_OF_02 = $last_updated;
4664
4665         my $age = time;
4666         if ($CPAN::META->has_inst('HTTP::Date')) {
4667             require HTTP::Date;
4668             $age -= HTTP::Date::str2time($last_updated);
4669         } else {
4670             $CPAN::Frontend->mywarn("  HTTP::Date not available\n");
4671             require Time::Local;
4672             my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
4673             $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
4674             $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
4675         }
4676         $age /= 3600*24;
4677         if ($age > 30) {
4678
4679             $CPAN::Frontend
4680                 ->mywarn(sprintf
4681                          qq{Warning: This index file is %d days old.
4682   Please check the host you chose as your CPAN mirror for staleness.
4683   I'll continue but problems seem likely to happen.\a\n},
4684                          $age);
4685
4686         } elsif ($age < -1) {
4687
4688             $CPAN::Frontend
4689                 ->mywarn(sprintf
4690                          qq{Warning: Your system date is %d days behind this index file!
4691   System time:          %s
4692   Timestamp index file: %s
4693   Please fix your system time, problems with the make command expected.\n},
4694                          -$age,
4695                          scalar gmtime,
4696                          $DATE_OF_02,
4697                         );
4698
4699         }
4700     }
4701
4702
4703     # A necessity since we have metadata_cache: delete what isn't
4704     # there anymore
4705     my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
4706     CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
4707     my(%exists);
4708     my $i = 0;
4709     my $painted = 0;
4710     foreach (@lines) {
4711         # before 1.56 we split into 3 and discarded the rest. From
4712         # 1.57 we assign remaining text to $comment thus allowing to
4713         # influence isa_perl
4714         my($mod,$version,$dist,$comment) = split " ", $_, 4;
4715         my($bundle,$id,$userid);
4716
4717         if ($mod eq 'CPAN' &&
4718             ! (
4719                CPAN::Queue->exists('Bundle::CPAN') ||
4720                CPAN::Queue->exists('CPAN')
4721               )
4722            ) {
4723             local($^W)= 0;
4724             if ($version > $CPAN::VERSION){
4725                 $CPAN::Frontend->mywarn(qq{
4726   New CPAN.pm version (v$version) available.
4727   [Currently running version is v$CPAN::VERSION]
4728   You might want to try
4729     install CPAN
4730     reload cpan
4731   to both upgrade CPAN.pm and run the new version without leaving
4732   the current session.
4733
4734 }); #});
4735                 $CPAN::Frontend->mysleep(2);
4736                 $CPAN::Frontend->myprint(qq{\n});
4737             }
4738             last if $CPAN::Signal;
4739         } elsif ($mod =~ /^Bundle::(.*)/) {
4740             $bundle = $1;
4741         }
4742
4743         if ($bundle){
4744             $id =  $CPAN::META->instance('CPAN::Bundle',$mod);
4745             # Let's make it a module too, because bundles have so much
4746             # in common with modules.
4747
4748             # Changed in 1.57_63: seems like memory bloat now without
4749             # any value, so commented out
4750
4751             # $CPAN::META->instance('CPAN::Module',$mod);
4752
4753         } else {
4754
4755             # instantiate a module object
4756             $id = $CPAN::META->instance('CPAN::Module',$mod);
4757
4758         }
4759
4760         # Although CPAN prohibits same name with different version the
4761         # indexer may have changed the version for the same distro
4762         # since the last time ("Force Reindexing" feature)
4763         if ($id->cpan_file ne $dist
4764             ||
4765             $id->cpan_version ne $version
4766            ){
4767             $userid = $id->userid || $self->userid($dist);
4768             $id->set(
4769                      'CPAN_USERID' => $userid,
4770                      'CPAN_VERSION' => $version,
4771                      'CPAN_FILE' => $dist,
4772                     );
4773         }
4774
4775         # instantiate a distribution object
4776         if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
4777           # we do not need CONTAINSMODS unless we do something with
4778           # this dist, so we better produce it on demand.
4779
4780           ## my $obj = $CPAN::META->instance(
4781           ##                              'CPAN::Distribution' => $dist
4782           ##                             );
4783           ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
4784         } else {
4785           $CPAN::META->instance(
4786                                 'CPAN::Distribution' => $dist
4787                                )->set(
4788                                       'CPAN_USERID' => $userid,
4789                                       'CPAN_COMMENT' => $comment,
4790                                      );
4791         }
4792         if ($secondtime) {
4793             for my $name ($mod,$dist) {
4794                 # $self->debug("exists name[$name]") if $CPAN::DEBUG;
4795                 $exists{$name} = undef;
4796             }
4797         }
4798         $i++;
4799         while (($painted/76) < ($i/@lines)) {
4800             $CPAN::Frontend->myprint(".");
4801             $painted++;
4802         }
4803         return if $CPAN::Signal;
4804     }
4805     $CPAN::Frontend->myprint("DONE\n");
4806     if ($secondtime) {
4807         for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
4808             for my $o ($CPAN::META->all_objects($class)) {
4809                 next if exists $exists{$o->{ID}};
4810                 $CPAN::META->delete($class,$o->{ID});
4811                 # CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
4812                 #     if $CPAN::DEBUG;
4813             }
4814         }
4815     }
4816 }
4817
4818 #-> sub CPAN::Index::rd_modlist ;
4819 sub rd_modlist {
4820     my($cl,$index_target) = @_;
4821     return unless defined $index_target;
4822     return if CPAN::_sqlite_running;
4823     $CPAN::Frontend->myprint("Going to read $index_target\n");
4824     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
4825     local $_;
4826     my $slurp = "";
4827     my $chunk;
4828     while (my $bytes = $fh->READ(\$chunk,8192)) {
4829         $slurp.=$chunk;
4830     }
4831     my @eval2 = split /\012/, $slurp;
4832
4833     while (@eval2) {
4834         my $shift = shift(@eval2);
4835         if ($shift =~ /^Date:\s+(.*)/){
4836             if ($DATE_OF_03 eq $1){
4837                 $CPAN::Frontend->myprint("Unchanged.\n");
4838                 return;
4839             }
4840             ($DATE_OF_03) = $1;
4841         }
4842         last if $shift =~ /^\s*$/;
4843     }
4844     push @eval2, q{CPAN::Modulelist->data;};
4845     local($^W) = 0;
4846     my($comp) = Safe->new("CPAN::Safe1");
4847     my($eval2) = join("\n", @eval2);
4848     CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG;
4849     my $ret = $comp->reval($eval2);
4850     Carp::confess($@) if $@;
4851     return if $CPAN::Signal;
4852     my $i = 0;
4853     my $until = keys(%$ret);
4854     my $painted = 0;
4855     CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
4856     for (keys %$ret) {
4857         my $obj = $CPAN::META->instance("CPAN::Module",$_);
4858         delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
4859         $obj->set(%{$ret->{$_}});
4860         $i++;
4861         while (($painted/76) < ($i/$until)) {
4862             $CPAN::Frontend->myprint(".");
4863             $painted++;
4864         }
4865         return if $CPAN::Signal;
4866     }
4867     $CPAN::Frontend->myprint("DONE\n");
4868 }
4869
4870 #-> sub CPAN::Index::write_metadata_cache ;
4871 sub write_metadata_cache {
4872     my($self) = @_;
4873     return unless $CPAN::Config->{'cache_metadata'};
4874     return if CPAN::_sqlite_running;
4875     return unless $CPAN::META->has_usable("Storable");
4876     my $cache;
4877     foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
4878                       CPAN::Distribution)) {
4879         $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
4880     }
4881     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
4882     $cache->{last_time} = $LAST_TIME;
4883     $cache->{DATE_OF_02} = $DATE_OF_02;
4884     $cache->{PROTOCOL} = PROTOCOL;
4885     $CPAN::Frontend->myprint("Going to write $metadata_file\n");
4886     eval { Storable::nstore($cache, $metadata_file) };
4887     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
4888 }
4889
4890 #-> sub CPAN::Index::read_metadata_cache ;
4891 sub read_metadata_cache {
4892     my($self) = @_;
4893     return unless $CPAN::Config->{'cache_metadata'};
4894     return if CPAN::_sqlite_running;
4895     return unless $CPAN::META->has_usable("Storable");
4896     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
4897     return unless -r $metadata_file and -f $metadata_file;
4898     $CPAN::Frontend->myprint("Going to read $metadata_file\n");
4899     my $cache;
4900     eval { $cache = Storable::retrieve($metadata_file) };
4901     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
4902     if (!$cache || !UNIVERSAL::isa($cache, 'HASH')){
4903         $LAST_TIME = 0;
4904         return;
4905     }
4906     if (exists $cache->{PROTOCOL}) {
4907         if (PROTOCOL > $cache->{PROTOCOL}) {
4908             $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
4909                                             "with protocol v%s, requiring v%s\n",
4910                                             $cache->{PROTOCOL},
4911                                             PROTOCOL)
4912                                    );
4913             return;
4914         }
4915     } else {
4916         $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
4917                                 "with protocol v1.0\n");
4918         return;
4919     }
4920     my $clcnt = 0;
4921     my $idcnt = 0;
4922     while(my($class,$v) = each %$cache) {
4923         next unless $class =~ /^CPAN::/;
4924         $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
4925         while (my($id,$ro) = each %$v) {
4926             $CPAN::META->{readwrite}{$class}{$id} ||=
4927                 $class->new(ID=>$id, RO=>$ro);
4928             $idcnt++;
4929         }
4930         $clcnt++;
4931     }
4932     unless ($clcnt) { # sanity check
4933         $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
4934         return;
4935     }
4936     if ($idcnt < 1000) {
4937         $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
4938                                  "in $metadata_file\n");
4939         return;
4940     }
4941     $CPAN::META->{PROTOCOL} ||=
4942         $cache->{PROTOCOL}; # reading does not up or downgrade, but it
4943                             # does initialize to some protocol
4944     $LAST_TIME = $cache->{last_time};
4945     $DATE_OF_02 = $cache->{DATE_OF_02};
4946     $CPAN::Frontend->myprint("  Database was generated on $DATE_OF_02\n")
4947         if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
4948     return;
4949 }
4950
4951 package CPAN::InfoObj;
4952 use strict;
4953
4954 sub ro {
4955     my $self = shift;
4956     exists $self->{RO} and return $self->{RO};
4957 }
4958
4959 #-> sub CPAN::InfoObj::cpan_userid
4960 sub cpan_userid {
4961     my $self = shift;
4962     my $ro = $self->ro;
4963     if ($ro) {
4964         return $ro->{CPAN_USERID} || "N/A";
4965     } else {
4966         $self->debug("ID[$self->{ID}]");
4967         # N/A for bundles found locally
4968         return "N/A";
4969     }
4970 }
4971
4972 sub id { shift->{ID}; }
4973
4974 #-> sub CPAN::InfoObj::new ;
4975 sub new {
4976     my $this = bless {}, shift;
4977     %$this = @_;
4978     $this
4979 }
4980
4981 # The set method may only be used by code that reads index data or
4982 # otherwise "objective" data from the outside world. All session
4983 # related material may do anything else with instance variables but
4984 # must not touch the hash under the RO attribute. The reason is that
4985 # the RO hash gets written to Metadata file and is thus persistent.
4986
4987 #-> sub CPAN::InfoObj::safe_chdir ;
4988 sub safe_chdir {
4989   my($self,$todir) = @_;
4990   # we die if we cannot chdir and we are debuggable
4991   Carp::confess("safe_chdir called without todir argument")
4992         unless defined $todir and length $todir;
4993   if (chdir $todir) {
4994     $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
4995         if $CPAN::DEBUG;
4996   } else {
4997     if (-e $todir) {
4998         unless (-x $todir) {
4999             unless (chmod 0755, $todir) {
5000                 my $cwd = CPAN::anycwd();
5001                 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
5002                                         "permission to change the permission; cannot ".
5003                                         "chdir to '$todir'\n");
5004                 $CPAN::Frontend->mysleep(5);
5005                 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
5006                                        qq{to todir[$todir]: $!});
5007             }
5008         }
5009     } else {
5010         $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n");
5011     }
5012     if (chdir $todir) {
5013       $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
5014           if $CPAN::DEBUG;
5015     } else {
5016       my $cwd = CPAN::anycwd();
5017       $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
5018                              qq{to todir[$todir] (a chmod has been issued): $!});
5019     }
5020   }
5021 }
5022
5023 #-> sub CPAN::InfoObj::set ;
5024 sub set {
5025     my($self,%att) = @_;
5026     my $class = ref $self;
5027
5028     # This must be ||=, not ||, because only if we write an empty
5029     # reference, only then the set method will write into the readonly
5030     # area. But for Distributions that spring into existence, maybe
5031     # because of a typo, we do not like it that they are written into
5032     # the readonly area and made permanent (at least for a while) and
5033     # that is why we do not "allow" other places to call ->set.
5034     unless ($self->id) {
5035         CPAN->debug("Bug? Empty ID, rejecting");
5036         return;
5037     }
5038     my $ro = $self->{RO} =
5039         $CPAN::META->{readonly}{$class}{$self->id} ||= {};
5040
5041     while (my($k,$v) = each %att) {
5042         $ro->{$k} = $v;
5043     }
5044 }
5045
5046 #-> sub CPAN::InfoObj::as_glimpse ;
5047 sub as_glimpse {
5048     my($self) = @_;
5049     my(@m);
5050     my $class = ref($self);
5051     $class =~ s/^CPAN:://;
5052     my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID};
5053     push @m, sprintf "%-15s %s\n", $class, $id;
5054     join "", @m;
5055 }
5056
5057 #-> sub CPAN::InfoObj::as_string ;
5058 sub as_string {
5059     my($self) = @_;
5060     my(@m);
5061     my $class = ref($self);
5062     $class =~ s/^CPAN:://;
5063     push @m, $class, " id = $self->{ID}\n";
5064     my $ro;
5065     unless ($ro = $self->ro) {
5066         if (substr($self->{ID},-1,1) eq ".") { # directory
5067             $ro = +{};
5068         } else {
5069             $CPAN::Frontend->mydie("Unknown object $self->{ID}");
5070         }
5071     }
5072     for (sort keys %$ro) {
5073         # next if m/^(ID|RO)$/;
5074         my $extra = "";
5075         if ($_ eq "CPAN_USERID") {
5076             $extra .= " (";
5077             $extra .= $self->fullname;
5078             my $email; # old perls!
5079             if ($email = $CPAN::META->instance("CPAN::Author",
5080                                                $self->cpan_userid
5081                                               )->email) {
5082                 $extra .= " <$email>";
5083             } else {
5084                 $extra .= " <no email>";
5085             }
5086             $extra .= ")";
5087         } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
5088             push @m, sprintf "    %-12s %s\n", $_, $self->fullname;
5089             next;
5090         }
5091         next unless defined $ro->{$_};
5092         push @m, sprintf "    %-12s %s%s\n", $_, $ro->{$_}, $extra;
5093     }
5094   KEY: for (sort keys %$self) {
5095         next if m/^(ID|RO)$/;
5096         unless (defined $self->{$_}) {
5097             delete $self->{$_};
5098             next KEY;
5099         }
5100         if (ref($self->{$_}) eq "ARRAY") {
5101           push @m, sprintf "    %-12s %s\n", $_, "@{$self->{$_}}";
5102         } elsif (ref($self->{$_}) eq "HASH") {
5103             my $value;
5104             if (/^CONTAINSMODS$/) {
5105                 $value = join(" ",sort keys %{$self->{$_}});
5106             } elsif (/^prereq_pm$/) {
5107                 my @value;
5108                 my $v = $self->{$_};
5109                 for my $x (sort keys %$v) {
5110                     my @svalue;
5111                     for my $y (sort keys %{$v->{$x}}) {
5112                         push @svalue, "$y=>$v->{$x}{$y}";
5113                     }
5114                     push @value, "$x\:" . join ",", @svalue if @svalue;
5115                 }
5116                 $value = join ";", @value;
5117             } else {
5118                 $value = $self->{$_};
5119             }
5120           push @m, sprintf(
5121                            "    %-12s %s\n",
5122                            $_,
5123                            $value,
5124                           );
5125         } else {
5126           push @m, sprintf "    %-12s %s\n", $_, $self->{$_};
5127         }
5128     }
5129     join "", @m, "\n";
5130 }
5131
5132 #-> sub CPAN::InfoObj::fullname ;
5133 sub fullname {
5134     my($self) = @_;
5135     $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
5136 }
5137
5138 #-> sub CPAN::InfoObj::dump ;
5139 sub dump {
5140   my($self, $what) = @_;
5141   unless ($CPAN::META->has_inst("Data::Dumper")) {
5142       $CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
5143   }
5144   local $Data::Dumper::Sortkeys;
5145   $Data::Dumper::Sortkeys = 1;
5146   my $out = Data::Dumper::Dumper($what ? eval $what : $self);
5147   if (length $out > 100000) {
5148       my $fh_pager = FileHandle->new;
5149       local($SIG{PIPE}) = "IGNORE";
5150       my $pager = $CPAN::Config->{'pager'} || "cat";
5151       $fh_pager->open("|$pager")
5152           or die "Could not open pager $pager\: $!";
5153       $fh_pager->print($out);
5154       close $fh_pager;
5155   } else {
5156       $CPAN::Frontend->myprint($out);
5157   }
5158 }
5159
5160 package CPAN::Author;
5161 use strict;
5162
5163 #-> sub CPAN::Author::force
5164 sub force {
5165     my $self = shift;
5166     $self->{force}++;
5167 }
5168
5169 #-> sub CPAN::Author::force
5170 sub unforce {
5171     my $self = shift;
5172     delete $self->{force};
5173 }
5174
5175 #-> sub CPAN::Author::id
5176 sub id {
5177     my $self = shift;
5178     my $id = $self->{ID};
5179     $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
5180     $id;
5181 }
5182
5183 #-> sub CPAN::Author::as_glimpse ;
5184 sub as_glimpse {
5185     my($self) = @_;
5186     my(@m);
5187     my $class = ref($self);
5188     $class =~ s/^CPAN:://;
5189     push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
5190                      $class,
5191                      $self->{ID},
5192                      $self->fullname,
5193                      $self->email);
5194     join "", @m;
5195 }
5196
5197 #-> sub CPAN::Author::fullname ;
5198 sub fullname {
5199     shift->ro->{FULLNAME};
5200 }
5201 *name = \&fullname;
5202
5203 #-> sub CPAN::Author::email ;
5204 sub email    { shift->ro->{EMAIL}; }
5205
5206 #-> sub CPAN::Author::ls ;
5207 sub ls {
5208     my $self = shift;
5209     my $glob = shift || "";
5210     my $silent = shift || 0;
5211     my $id = $self->id;
5212
5213     # adapted from CPAN::Distribution::verifyCHECKSUM ;
5214     my(@csf); # chksumfile
5215     @csf = $self->id =~ /(.)(.)(.*)/;
5216     $csf[1] = join "", @csf[0,1];
5217     $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
5218     my(@dl);
5219     @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
5220     unless (grep {$_->[2] eq $csf[1]} @dl) {
5221         $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
5222         return;
5223     }
5224     @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
5225     unless (grep {$_->[2] eq $csf[2]} @dl) {
5226         $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
5227         return;
5228     }
5229     @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
5230     if ($glob) {
5231         if ($CPAN::META->has_inst("Text::Glob")) {
5232             my $rglob = Text::Glob::glob_to_regex($glob);
5233             @dl = grep { $_->[2] =~ /$rglob/ } @dl;
5234         } else {
5235             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
5236         }
5237     }
5238     $CPAN::Frontend->myprint(join "", map {
5239         sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
5240     } sort { $a->[2] cmp $b->[2] } @dl);
5241     @dl;
5242 }
5243
5244 # returns an array of arrays, the latter contain (size,mtime,filename)
5245 #-> sub CPAN::Author::dir_listing ;
5246 sub dir_listing {
5247     my $self = shift;
5248     my $chksumfile = shift;
5249     my $recursive = shift;
5250     my $may_ftp = shift;
5251
5252     my $lc_want =
5253         File::Spec->catfile($CPAN::Config->{keep_source_where},
5254                             "authors", "id", @$chksumfile);
5255
5256     my $fh;
5257
5258     # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
5259     # hazard.  (Without GPG installed they are not that much better,
5260     # though.)
5261     $fh = FileHandle->new;
5262     if (open($fh, $lc_want)) {
5263         my $line = <$fh>; close $fh;
5264         unlink($lc_want) unless $line =~ /PGP/;
5265     }
5266
5267     local($") = "/";
5268     # connect "force" argument with "index_expire".
5269     my $force = $self->{force};
5270     if (my @stat = stat $lc_want) {
5271         $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
5272     }
5273     my $lc_file;
5274     if ($may_ftp) {
5275         $lc_file = CPAN::FTP->localize(
5276                                        "authors/id/@$chksumfile",
5277                                        $lc_want,
5278                                        $force,
5279                                       );
5280         unless ($lc_file) {
5281             $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
5282             $chksumfile->[-1] .= ".gz";
5283             $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
5284                                            "$lc_want.gz",1);
5285             if ($lc_file) {
5286                 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
5287                 eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
5288             } else {
5289                 return;
5290             }
5291         }
5292     } else {
5293         $lc_file = $lc_want;
5294         # we *could* second-guess and if the user has a file: URL,
5295         # then we could look there. But on the other hand, if they do
5296         # have a file: URL, wy did they choose to set
5297         # $CPAN::Config->{show_upload_date} to false?
5298     }
5299
5300     # adapted from CPAN::Distribution::CHECKSUM_check_file ;
5301     $fh = FileHandle->new;
5302     my($cksum);
5303     if (open $fh, $lc_file){
5304         local($/);
5305         my $eval = <$fh>;
5306         $eval =~ s/\015?\012/\n/g;
5307         close $fh;
5308         my($comp) = Safe->new();
5309         $cksum = $comp->reval($eval);
5310         if ($@) {
5311             rename $lc_file, "$lc_file.bad";
5312             Carp::confess($@) if $@;
5313         }
5314     } elsif ($may_ftp) {
5315         Carp::carp "Could not open '$lc_file' for reading.";
5316     } else {
5317         # Maybe should warn: "You may want to set show_upload_date to a true value"
5318         return;
5319     }
5320     my(@result,$f);
5321     for $f (sort keys %$cksum) {
5322         if (exists $cksum->{$f}{isdir}) {
5323             if ($recursive) {
5324                 my(@dir) = @$chksumfile;
5325                 pop @dir;
5326                 push @dir, $f, "CHECKSUMS";
5327                 push @result, map {
5328                     [$_->[0], $_->[1], "$f/$_->[2]"]
5329                 } $self->dir_listing(\@dir,1,$may_ftp);
5330             } else {
5331                 push @result, [ 0, "-", $f ];
5332             }
5333         } else {
5334             push @result, [
5335                            ($cksum->{$f}{"size"}||0),
5336                            $cksum->{$f}{"mtime"}||"---",
5337                            $f
5338                           ];
5339         }
5340     }
5341     @result;
5342 }
5343
5344 package CPAN::Distribution;
5345 use strict;
5346
5347 # Accessors
5348 sub cpan_comment {
5349     my $self = shift;
5350     my $ro = $self->ro or return;
5351     $ro->{CPAN_COMMENT}
5352 }
5353
5354 # CPAN::Distribution::undelay
5355 sub undelay {
5356     my $self = shift;
5357     delete $self->{later};
5358 }
5359
5360 # add the A/AN/ stuff
5361 # CPAN::Distribution::normalize
5362 sub normalize {
5363     my($self,$s) = @_;
5364     $s = $self->id unless defined $s;
5365     if (substr($s,-1,1) eq ".") {
5366         # using a global because we are sometimes called as static method
5367         if (!$CPAN::META->{LOCK}
5368             && !$CPAN::Have_warned->{"$s is unlocked"}++
5369            ) {
5370             $CPAN::Frontend->mywarn("You are visiting the local directory
5371   '$s'
5372   without lock, take care that concurrent processes do not do likewise.\n");
5373             $CPAN::Frontend->mysleep(1);
5374         }
5375         if ($s eq ".") {
5376             $s = "$CPAN::iCwd/.";
5377         } elsif (File::Spec->file_name_is_absolute($s)) {
5378         } elsif (File::Spec->can("rel2abs")) {
5379             $s = File::Spec->rel2abs($s);
5380         } else {
5381             $CPAN::Frontend->mydie("Your File::Spec is too old, please upgrade File::Spec");
5382         }
5383         CPAN->debug("s[$s]") if $CPAN::DEBUG;
5384         unless ($CPAN::META->exists("CPAN::Distribution", $s)) {
5385             for ($CPAN::META->instance("CPAN::Distribution", $s)) {
5386                 $_->{build_dir} = $s;
5387                 $_->{archived} = "local_directory";
5388                 $_->{unwrapped} = CPAN::Distrostatus->new("YES -- local_directory");
5389             }
5390         }
5391     } elsif (
5392         $s =~ tr|/|| == 1
5393         or
5394         $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
5395        ) {
5396         return $s if $s =~ m:^N/A|^Contact Author: ;
5397         $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
5398             $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
5399         CPAN->debug("s[$s]") if $CPAN::DEBUG;
5400     }
5401     $s;
5402 }
5403
5404 #-> sub CPAN::Distribution::author ;
5405 sub author {
5406     my($self) = @_;
5407     my($authorid);
5408     if (substr($self->id,-1,1) eq ".") {
5409         $authorid = "LOCAL";
5410     } else {
5411         ($authorid) = $self->pretty_id =~ /^([\w\-]+)/;
5412     }
5413     CPAN::Shell->expand("Author",$authorid);
5414 }
5415
5416 # tries to get the yaml from CPAN instead of the distro itself:
5417 # EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels
5418 sub fast_yaml {
5419     my($self) = @_;
5420     my $meta = $self->pretty_id;
5421     $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/;
5422     my(@ls) = CPAN::Shell->globls($meta);
5423     my $norm = $self->normalize($meta);
5424
5425     my($local_file);
5426     my($local_wanted) =
5427         File::Spec->catfile(
5428                             $CPAN::Config->{keep_source_where},
5429                             "authors",
5430                             "id",
5431                             split(/\//,$norm)
5432                            );
5433     $self->debug("Doing localize") if $CPAN::DEBUG;
5434     unless ($local_file =
5435             CPAN::FTP->localize("authors/id/$norm",
5436                                 $local_wanted)) {
5437         $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n");
5438     }
5439     my $yaml = CPAN->_yaml_loadfile($local_file)->[0];
5440 }
5441
5442 #-> sub CPAN::Distribution::cpan_userid
5443 sub cpan_userid {
5444     my $self = shift;
5445     if ($self->{ID} =~ m{[A-Z]/[A-Z\-]{2}/([A-Z\-]+)/}) {
5446         return $1;
5447     }
5448     return $self->SUPER::cpan_userid;
5449 }
5450
5451 #-> sub CPAN::Distribution::pretty_id
5452 sub pretty_id {
5453     my $self = shift;
5454     my $id = $self->id;
5455     return $id unless $id =~ m|^./../|;
5456     substr($id,5);
5457 }
5458
5459 # mark as dirty/clean for the sake of recursion detection. $color=1
5460 # means "in use", $color=0 means "not in use anymore". $color=2 means
5461 # we have determined prereqs now and thus insist on passing this
5462 # through (at least) once again.
5463
5464 #-> sub CPAN::Distribution::color_cmd_tmps ;
5465 sub color_cmd_tmps {
5466     my($self) = shift;
5467     my($depth) = shift || 0;
5468     my($color) = shift || 0;
5469     my($ancestors) = shift || [];
5470     # a distribution needs to recurse into its prereq_pms
5471
5472     return if exists $self->{incommandcolor}
5473         && $color==1
5474         && $self->{incommandcolor}==$color;
5475     if ($depth>=$CPAN::MAX_RECURSION){
5476         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
5477     }
5478     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5479     my $prereq_pm = $self->prereq_pm;
5480     if (defined $prereq_pm) {
5481       PREREQ: for my $pre (keys %{$prereq_pm->{requires}||{}},
5482                            keys %{$prereq_pm->{build_requires}||{}}) {
5483             next PREREQ if $pre eq "perl";
5484             my $premo;
5485             unless ($premo = CPAN::Shell->expand("Module",$pre)) {
5486                 $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n");
5487                 $CPAN::Frontend->mysleep(2);
5488                 next PREREQ;
5489             }
5490             $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5491         }
5492     }
5493     if ($color==0) {
5494         delete $self->{sponsored_mods};
5495
5496         # as we are at the end of a command, we'll give up this
5497         # reminder of a broken test. Other commands may test this guy
5498         # again. Maybe 'badtestcnt' should be renamed to
5499         # 'make_test_failed_within_command'?
5500         delete $self->{badtestcnt};
5501     }
5502     $self->{incommandcolor} = $color;
5503 }
5504
5505 #-> sub CPAN::Distribution::as_string ;
5506 sub as_string {
5507   my $self = shift;
5508   $self->containsmods;
5509   $self->upload_date;
5510   $self->SUPER::as_string(@_);
5511 }
5512
5513 #-> sub CPAN::Distribution::containsmods ;
5514 sub containsmods {
5515   my $self = shift;
5516   return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
5517   my $dist_id = $self->{ID};
5518   for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
5519     my $mod_file = $mod->cpan_file or next;
5520     my $mod_id = $mod->{ID} or next;
5521     # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
5522     # sleep 1;
5523     if ($CPAN::Signal) {
5524         delete $self->{CONTAINSMODS};
5525         return;
5526     }
5527     $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
5528   }
5529   keys %{$self->{CONTAINSMODS}||{}};
5530 }
5531
5532 #-> sub CPAN::Distribution::upload_date ;
5533 sub upload_date {
5534   my $self = shift;
5535   return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
5536   my(@local_wanted) = split(/\//,$self->id);
5537   my $filename = pop @local_wanted;
5538   push @local_wanted, "CHECKSUMS";
5539   my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
5540   return unless $author;
5541   my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
5542   return unless @dl;
5543   my($dirent) = grep { $_->[2] eq $filename } @dl;
5544   # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
5545   return unless $dirent->[1];
5546   return $self->{UPLOAD_DATE} = $dirent->[1];
5547 }
5548
5549 #-> sub CPAN::Distribution::uptodate ;
5550 sub uptodate {
5551     my($self) = @_;
5552     my $c;
5553     foreach $c ($self->containsmods) {
5554         my $obj = CPAN::Shell->expandany($c);
5555         unless ($obj->uptodate){
5556             my $id = $self->pretty_id;
5557             $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG;
5558             return 0;
5559         }
5560     }
5561     return 1;
5562 }
5563
5564 #-> sub CPAN::Distribution::called_for ;
5565 sub called_for {
5566     my($self,$id) = @_;
5567     $self->{CALLED_FOR} = $id if defined $id;
5568     return $self->{CALLED_FOR};
5569 }
5570
5571 #-> sub CPAN::Distribution::get ;
5572 sub get {
5573     my($self) = @_;
5574     $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
5575     if (my $goto = $self->prefs->{goto}) {
5576         $CPAN::Frontend->mywarn
5577             (sprintf(
5578                      "delegating to '%s' as specified in prefs file '%s' doc %d\n",
5579                      $goto,
5580                      $self->{prefs_file},
5581                      $self->{prefs_file_doc},
5582                     ));
5583         return $self->goto($goto);
5584     }
5585     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
5586                            ? $ENV{PERL5LIB}
5587                            : ($ENV{PERLLIB} || "");
5588
5589     $CPAN::META->set_perl5lib;
5590     local $ENV{MAKEFLAGS}; # protect us from outer make calls
5591
5592   EXCUSE: {
5593         my @e;
5594         $self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG;
5595         if ($self->prefs->{disabled}) {
5596             my $why = sprintf(
5597                               "Disabled via prefs file '%s' doc %d",
5598                               $self->{prefs_file},
5599                               $self->{prefs_file_doc},
5600                              );
5601             push @e, $why;
5602             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $why");
5603             # note: not intended to be persistent but at least visible
5604             # during this session
5605         } else {
5606             if (exists $self->{build_dir}) {
5607                 # this deserves print, not warn:
5608                 $CPAN::Frontend->myprint("  Has already been unwrapped into directory ".
5609                                          "$self->{build_dir}\n"
5610                                         );
5611                 return;
5612             }
5613
5614             # although we talk about 'force' we shall not test on
5615             # force directly. New model of force tries to refrain from
5616             # direct checking of force.
5617             exists $self->{unwrapped} and (
5618                                            UNIVERSAL::can($self->{unwrapped},"failed") ?
5619                                            $self->{unwrapped}->failed :
5620                                            $self->{unwrapped} =~ /^NO/
5621                                           )
5622                 and push @e, "Unwrapping had some problem, won't try again without force";
5623         }
5624
5625         $CPAN::Frontend->mywarn(join "", map {"$_\n"} @e) and return if @e;
5626     }
5627     my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
5628
5629     #
5630     # Get the file on local disk
5631     #
5632
5633     my($local_file);
5634     my($local_wanted) =
5635         File::Spec->catfile(
5636                             $CPAN::Config->{keep_source_where},
5637                             "authors",
5638                             "id",
5639                             split(/\//,$self->id)
5640                            );
5641
5642     $self->debug("Doing localize") if $CPAN::DEBUG;
5643     unless ($local_file =
5644             CPAN::FTP->localize("authors/id/$self->{ID}",
5645                                 $local_wanted)) {
5646         my $note = "";
5647         if ($CPAN::Index::DATE_OF_02) {
5648             $note = "Note: Current database in memory was generated ".
5649                 "on $CPAN::Index::DATE_OF_02\n";
5650         }
5651         $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
5652     }
5653
5654     $self->debug("local_wanted[$local_wanted]local_file[$local_file]") if $CPAN::DEBUG;
5655     $self->{localfile} = $local_file;
5656     return if $CPAN::Signal;
5657
5658     #
5659     # Check integrity
5660     #
5661     if ($CPAN::META->has_inst("Digest::SHA")) {
5662         $self->debug("Digest::SHA is installed, verifying");
5663         $self->verifyCHECKSUM;
5664     } else {
5665         $self->debug("Digest::SHA is NOT installed");
5666     }
5667     return if $CPAN::Signal;
5668
5669     #
5670     # Create a clean room and go there
5671     #
5672     $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
5673     my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
5674     $self->safe_chdir($builddir);
5675     $self->debug("Removing tmp-$$") if $CPAN::DEBUG;
5676     File::Path::rmtree("tmp-$$");
5677     unless (mkdir "tmp-$$", 0755) {
5678         $CPAN::Frontend->unrecoverable_error(<<EOF);
5679 Couldn't mkdir '$builddir/tmp-$$': $!
5680
5681 Cannot continue: Please find the reason why I cannot make the
5682 directory
5683 $builddir/tmp-$$
5684 and fix the problem, then retry.
5685
5686 EOF
5687     }
5688     if ($CPAN::Signal){
5689         $self->safe_chdir($sub_wd);
5690         return;
5691     }
5692     $self->safe_chdir("tmp-$$");
5693
5694     #
5695     # Unpack the goods
5696     #
5697     my $ct = eval{CPAN::Tarzip->new($local_file)};
5698     unless ($ct) {
5699         $self->{unwrapped} = CPAN::Distrostatus->new("NO");
5700         delete $self->{build_dir};
5701         return;
5702     }
5703     if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i){
5704         $self->{was_uncompressed}++ unless eval{$ct->gtest()};
5705         $self->untar_me($ct);
5706     } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
5707         $self->unzip_me($ct);
5708     } else {
5709         $self->{was_uncompressed}++ unless $ct->gtest();
5710         $local_file = $self->handle_singlefile($local_file);
5711 #    } else {
5712 #       $self->{archived} = "NO";
5713 #        $self->safe_chdir($sub_wd);
5714 #        return;
5715     }
5716
5717     # we are still in the tmp directory!
5718     # Let's check if the package has its own directory.
5719     my $dh = DirHandle->new(File::Spec->curdir)
5720         or Carp::croak("Couldn't opendir .: $!");
5721     my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
5722     $dh->close;
5723     my ($packagedir);
5724     # XXX here we want in each branch File::Temp to protect all build_dir directories
5725     if (CPAN->has_inst("File::Temp")) {
5726         my $tdir_base;
5727         my $from_dir;
5728         my @dirents;
5729         if (@readdir == 1 && -d $readdir[0]) {
5730             $tdir_base = $readdir[0];
5731             $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]);
5732             my $dh2 = DirHandle->new($from_dir)
5733                 or Carp::croak("Couldn't opendir $from_dir: $!");
5734             @dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC??
5735         } else {
5736             my $userid = $self->cpan_userid;
5737             CPAN->debug("userid[$userid]");
5738             if (!$userid or $userid eq "N/A") {
5739                 $userid = "anon";
5740             }
5741             $tdir_base = $userid;
5742             $from_dir = File::Spec->curdir;
5743             @dirents = @readdir;
5744         }
5745         $packagedir = File::Temp::tempdir(
5746                                           "$tdir_base-XXXXXX",
5747                                           DIR => $builddir,
5748                                           CLEANUP => 0,
5749                                          );
5750         my $f;
5751         for $f (@dirents) { # is already without "." and ".."
5752             my $from = File::Spec->catdir($from_dir,$f);
5753             my $to = File::Spec->catdir($packagedir,$f);
5754             unless (File::Copy::move($from,$to)) {
5755                 my $err = $!;
5756                 $from = File::Spec->rel2abs($from);
5757                 Carp::confess("Couldn't move $from to $to: $err");
5758             }
5759         }
5760     } else { # older code below, still better than nothing when there is no File::Temp
5761         my($distdir);
5762         if (@readdir == 1 && -d $readdir[0]) {
5763             $distdir = $readdir[0];
5764             $packagedir = File::Spec->catdir($builddir,$distdir);
5765             $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
5766                 if $CPAN::DEBUG;
5767             -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
5768                                                         "$packagedir\n");
5769             File::Path::rmtree($packagedir);
5770             unless (File::Copy::move($distdir,$packagedir)) {
5771                 $CPAN::Frontend->unrecoverable_error(<<EOF);
5772 Couldn't move '$distdir' to '$packagedir': $!
5773
5774 Cannot continue: Please find the reason why I cannot move
5775 $builddir/tmp-$$/$distdir
5776 to
5777 $packagedir
5778 and fix the problem, then retry
5779
5780 EOF
5781             }
5782             $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
5783                                  $distdir,
5784                                  $packagedir,
5785                                  -e $packagedir,
5786                                  -d $packagedir,
5787                                 )) if $CPAN::DEBUG;
5788         } else {
5789             my $userid = $self->cpan_userid;
5790             CPAN->debug("userid[$userid]") if $CPAN::DEBUG;
5791             if (!$userid or $userid eq "N/A") {
5792                 $userid = "anon";
5793             }
5794             my $pragmatic_dir = $userid . '000';
5795             $pragmatic_dir =~ s/\W_//g;
5796             $pragmatic_dir++ while -d "../$pragmatic_dir";
5797             $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
5798             $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
5799             File::Path::mkpath($packagedir);
5800             my($f);
5801             for $f (@readdir) { # is already without "." and ".."
5802                 my $to = File::Spec->catdir($packagedir,$f);
5803                 File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
5804             }
5805         }
5806     }
5807     if ($CPAN::Signal){
5808         $self->safe_chdir($sub_wd);
5809         return;
5810     }
5811
5812     $self->{build_dir} = $packagedir;
5813     $self->safe_chdir($builddir);
5814     File::Path::rmtree("tmp-$$");
5815
5816     $self->safe_chdir($packagedir);
5817     $self->_signature_business();
5818     $self->safe_chdir($builddir);
5819     return if $CPAN::Signal;
5820
5821
5822     my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
5823     my($mpl_exists) = -f $mpl;
5824     unless ($mpl_exists) {
5825         # NFS has been reported to have racing problems after the
5826         # renaming of a directory in some environments.
5827         # This trick helps.
5828         $CPAN::Frontend->mysleep(1);
5829         my $mpldh = DirHandle->new($packagedir)
5830             or Carp::croak("Couldn't opendir $packagedir: $!");
5831         $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
5832         $mpldh->close;
5833     }
5834     my $prefer_installer = "eumm"; # eumm|mb
5835     if (-f File::Spec->catfile($packagedir,"Build.PL")) {
5836         if ($mpl_exists) { # they *can* choose
5837             if ($CPAN::META->has_inst("Module::Build")) {
5838                 $prefer_installer = CPAN::HandleConfig->prefs_lookup($self,
5839                                                                      q{prefer_installer});
5840             }
5841         } else {
5842             $prefer_installer = "mb";
5843         }
5844     }
5845     return unless $self->patch;
5846     if (lc($prefer_installer) eq "mb") {
5847         $self->{modulebuild} = 1;
5848     } elsif (! $mpl_exists) {
5849         $self->_edge_cases($mpl,$packagedir,$local_file);
5850     }
5851     if ($self->{build_dir}
5852         &&
5853         $CPAN::Config->{build_dir_reuse}
5854        ) {
5855         $self->store_persistent_state;
5856     }
5857
5858     return $self;
5859 }
5860
5861 #-> CPAN::Distribution::store_persistent_state
5862 sub store_persistent_state {
5863     my($self) = @_;
5864     my $dir = $self->{build_dir};
5865     unless (File::Spec->canonpath(File::Basename::dirname($dir))
5866             eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
5867         $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
5868                                 "will not store persistent state\n");
5869         return;
5870     }
5871     my $file = sprintf "%s.yml", $dir;
5872     my $yaml_module = CPAN::_yaml_module;
5873     if ($CPAN::META->has_inst($yaml_module)) {
5874         CPAN->_yaml_dumpfile(
5875                              $file,
5876                              {
5877                               time => time,
5878                               perl => CPAN::_perl_fingerprint,
5879                               distribution => $self,
5880                              }
5881                             );
5882     } else {
5883         $CPAN::Frontend->myprint("Warning (usually harmless): '$yaml_module' not installed, ".
5884                                 "will not store persistent state\n");
5885     }
5886 }
5887
5888 #-> CPAN::Distribution::patch
5889 sub try_download {
5890     my($self,$patch) = @_;
5891     my $norm = $self->normalize($patch);
5892     my($local_wanted) =
5893         File::Spec->catfile(
5894                             $CPAN::Config->{keep_source_where},
5895                             "authors",
5896                             "id",
5897                             split(/\//,$norm),
5898                             );
5899     $self->debug("Doing localize") if $CPAN::DEBUG;
5900     return CPAN::FTP->localize("authors/id/$norm",
5901                                $local_wanted);
5902 }
5903
5904 #-> CPAN::Distribution::patch
5905 sub patch {
5906     my($self) = @_;
5907     $self->debug("checking patches id[$self->{ID}]") if $CPAN::DEBUG;
5908     my $patches = $self->prefs->{patches};
5909     $patches ||= "";
5910     $self->debug("patches[$patches]") if $CPAN::DEBUG;
5911     if ($patches) {
5912         return unless @$patches;
5913         $self->safe_chdir($self->{build_dir});
5914         CPAN->debug("patches[$patches]") if $CPAN::DEBUG;
5915         my $patchbin = $CPAN::Config->{patch};
5916         unless ($patchbin && length $patchbin) {
5917             $CPAN::Frontend->mydie("No external patch command configured\n\n".
5918                                    "Please run 'o conf init /patch/'\n\n");
5919         }
5920         unless (MM->maybe_command($patchbin)) {
5921             $CPAN::Frontend->mydie("No external patch command available\n\n".
5922                                    "Please run 'o conf init /patch/'\n\n");
5923         }
5924         $patchbin = CPAN::HandleConfig->safe_quote($patchbin);
5925         local $ENV{PATCH_GET} = 0; # shall replace -g0 which is not
5926                                    # supported everywhere (and then,
5927                                    # not ever necessary there)
5928         my $stdpatchargs = "-N --fuzz=3";
5929         my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches");
5930         $CPAN::Frontend->myprint("Going to apply $countedpatches:\n");
5931         for my $patch (@$patches) {
5932             unless (-f $patch) {
5933                 if (my $trydl = $self->try_download($patch)) {
5934                     $patch = $trydl;
5935                 } else {
5936                     my $fail = "Could not find patch '$patch'";
5937                     $CPAN::Frontend->mywarn("$fail; cannot continue\n");
5938                     $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
5939                     delete $self->{build_dir};
5940                     return;
5941                 }
5942             }
5943             $CPAN::Frontend->myprint("  $patch\n");
5944             my $readfh = CPAN::Tarzip->TIEHANDLE($patch);
5945
5946             my $pcommand;
5947             my $ppp = $self->_patch_p_parameter($readfh);
5948             if ($ppp eq "applypatch") {
5949                 $pcommand = "$CPAN::Config->{applypatch} -verbose";
5950             } else {
5951                 my $thispatchargs = join " ", $stdpatchargs, $ppp;
5952                 $pcommand = "$patchbin $thispatchargs";
5953             }
5954
5955             $readfh = CPAN::Tarzip->TIEHANDLE($patch); # open again
5956             my $writefh = FileHandle->new;
5957             $CPAN::Frontend->myprint("  $pcommand\n");
5958             unless (open $writefh, "|$pcommand") {
5959                 my $fail = "Could not fork '$pcommand'";
5960                 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
5961                 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
5962                 delete $self->{build_dir};
5963                 return;
5964             }
5965             while (my $x = $readfh->READLINE) {
5966                 print $writefh $x;
5967             }
5968             unless (close $writefh) {
5969                 my $fail = "Could not apply patch '$patch'";
5970                 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
5971                 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
5972                 delete $self->{build_dir};
5973                 return;
5974             }
5975         }
5976         $self->{patched}++;
5977     }
5978     return 1;
5979 }
5980
5981 sub _patch_p_parameter {
5982     my($self,$fh) = @_;
5983     my $cnt_files   = 0;
5984     my $cnt_p0files = 0;
5985     local($_);
5986     while ($_ = $fh->READLINE) {
5987         if (
5988             $CPAN::Config->{applypatch}
5989             &&
5990             /\#\#\#\# ApplyPatch data follows \#\#\#\#/
5991            ) {
5992             return "applypatch"
5993         }
5994         next unless /^[\*\+]{3}\s(\S+)/;
5995         my $file = $1;
5996         $cnt_files++;
5997         $cnt_p0files++ if -f $file;
5998         CPAN->debug("file[$file]cnt_files[$cnt_files]cnt_p0files[$cnt_p0files]")
5999             if $CPAN::DEBUG;
6000     }
6001     return "-p1" unless $cnt_files;
6002     return $cnt_files==$cnt_p0files ? "-p0" : "-p1";
6003 }
6004
6005 #-> sub CPAN::Distribution::_edge_cases
6006 # with "configure" or "Makefile" or single file scripts
6007 sub _edge_cases {
6008     my($self,$mpl,$packagedir,$local_file) = @_;
6009     $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
6010                          $mpl,
6011                          CPAN::anycwd(),
6012                         )) if $CPAN::DEBUG;
6013     my($configure) = File::Spec->catfile($packagedir,"Configure");
6014     if (-f $configure) {
6015         # do we have anything to do?
6016         $self->{configure} = $configure;
6017     } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
6018         $CPAN::Frontend->mywarn(qq{
6019 Package comes with a Makefile and without a Makefile.PL.
6020 We\'ll try to build it with that Makefile then.
6021 });
6022         $self->{writemakefile} = CPAN::Distrostatus->new("YES");
6023         $CPAN::Frontend->mysleep(2);
6024     } else {
6025         my $cf = $self->called_for || "unknown";
6026         if ($cf =~ m|/|) {
6027             $cf =~ s|.*/||;
6028             $cf =~ s|\W.*||;
6029         }
6030         $cf =~ s|[/\\:]||g;     # risk of filesystem damage
6031         $cf = "unknown" unless length($cf);
6032         $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
6033   (The test -f "$mpl" returned false.)
6034   Writing one on our own (setting NAME to $cf)\a\n});
6035         $self->{had_no_makefile_pl}++;
6036         $CPAN::Frontend->mysleep(3);
6037
6038         # Writing our own Makefile.PL
6039
6040         my $script = "";
6041         if ($self->{archived} eq "maybe_pl") {
6042             my $fh = FileHandle->new;
6043             my $script_file = File::Spec->catfile($packagedir,$local_file);
6044             $fh->open($script_file)
6045                 or Carp::croak("Could not open $script_file: $!");
6046             local $/ = "\n";
6047             # name parsen und prereq
6048             my($state) = "poddir";
6049             my($name, $prereq) = ("", "");
6050             while (<$fh>) {
6051                 if ($state eq "poddir" && /^=head\d\s+(\S+)/) {
6052                     if ($1 eq 'NAME') {
6053                         $state = "name";
6054                     } elsif ($1 eq 'PREREQUISITES') {
6055                         $state = "prereq";
6056                     }
6057                 } elsif ($state =~ m{^(name|prereq)$}) {
6058                     if (/^=/) {
6059                         $state = "poddir";
6060                     } elsif (/^\s*$/) {
6061                         # nop
6062                     } elsif ($state eq "name") {
6063                         if ($name eq "") {
6064                             ($name) = /^(\S+)/;
6065                             $state = "poddir";
6066                         }
6067                     } elsif ($state eq "prereq") {
6068                         $prereq .= $_;
6069                     }
6070                 } elsif (/^=cut\b/) {
6071                     last;
6072                 }
6073             }
6074             $fh->close;
6075
6076             for ($name) {
6077                 s{.*<}{};       # strip X<...>
6078                 s{>.*}{};
6079             }
6080             chomp $prereq;
6081             $prereq = join " ", split /\s+/, $prereq;
6082             my($PREREQ_PM) = join("\n", map {
6083                 s{.*<}{};       # strip X<...>
6084                 s{>.*}{};
6085                 if (/[\s\'\"]/) { # prose?
6086                 } else {
6087                     s/[^\w:]$//; # period?
6088                     " "x28 . "'$_' => 0,";
6089                 }
6090             } split /\s*,\s*/, $prereq);
6091
6092             $script = "
6093               EXE_FILES => ['$name'],
6094               PREREQ_PM => {
6095 $PREREQ_PM
6096                            },
6097 ";
6098             if ($name) {
6099                 my $to_file = File::Spec->catfile($packagedir, $name);
6100                 rename $script_file, $to_file
6101                     or die "Can't rename $script_file to $to_file: $!";
6102             }
6103         }
6104
6105         my $fh = FileHandle->new;
6106         $fh->open(">$mpl")
6107             or Carp::croak("Could not open >$mpl: $!");
6108         $fh->print(
6109                    qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
6110 # because there was no Makefile.PL supplied.
6111 # Autogenerated on: }.scalar localtime().qq{
6112
6113 use ExtUtils::MakeMaker;
6114 WriteMakefile(
6115               NAME => q[$cf],$script
6116              );
6117 });
6118         $fh->close;
6119     }
6120 }
6121
6122 #-> CPAN::Distribution::_signature_business
6123 sub _signature_business {
6124     my($self) = @_;
6125     my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
6126                                                       q{check_sigs});
6127     if ($check_sigs) {
6128         if ($CPAN::META->has_inst("Module::Signature")) {
6129             if (-f "SIGNATURE") {
6130                 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
6131                 my $rv = Module::Signature::verify();
6132                 if ($rv != Module::Signature::SIGNATURE_OK() and
6133                     $rv != Module::Signature::SIGNATURE_MISSING()) {
6134                     $CPAN::Frontend->mywarn(
6135                                             qq{\nSignature invalid for }.
6136                                             qq{distribution file. }.
6137                                             qq{Please investigate.\n\n}
6138                                            );
6139
6140                     my $wrap =
6141                         sprintf(qq{I'd recommend removing %s. Its signature
6142 is invalid. Maybe you have configured your 'urllist' with
6143 a bad URL. Please check this array with 'o conf urllist', and
6144 retry. For more information, try opening a subshell with
6145   look %s
6146 and there run
6147   cpansign -v
6148 },
6149                                 $self->{localfile},
6150                                 $self->pretty_id,
6151                                );
6152                     $self->{signature_verify} = CPAN::Distrostatus->new("NO");
6153                     $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
6154                     $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
6155                 } else {
6156                     $self->{signature_verify} = CPAN::Distrostatus->new("YES");
6157                     $self->debug("Module::Signature has verified") if $CPAN::DEBUG;
6158                 }
6159             } else {
6160                 $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n});
6161             }
6162         } else {
6163             $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
6164         }
6165     }
6166 }
6167
6168 #-> CPAN::Distribution::untar_me ;
6169 sub untar_me {
6170     my($self,$ct) = @_;
6171     $self->{archived} = "tar";
6172     if ($ct->untar()) {
6173         $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6174     } else {
6175         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed");
6176     }
6177 }
6178
6179 # CPAN::Distribution::unzip_me ;
6180 sub unzip_me {
6181     my($self,$ct) = @_;
6182     $self->{archived} = "zip";
6183     if ($ct->unzip()) {
6184         $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6185     } else {
6186         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed");
6187     }
6188     return;
6189 }
6190
6191 sub handle_singlefile {
6192     my($self,$local_file) = @_;
6193
6194     if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ){
6195         $self->{archived} = "pm";
6196     } else {
6197         $self->{archived} = "maybe_pl";
6198     }
6199
6200     my $to = File::Basename::basename($local_file);
6201     if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
6202         if (eval{CPAN::Tarzip->new($local_file)->gunzip($to)}) {
6203             $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6204         } else {
6205             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- uncompressing failed");
6206         }
6207     } else {
6208         File::Copy::cp($local_file,".");
6209         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed");
6210     }
6211     return $to;
6212 }
6213
6214 #-> sub CPAN::Distribution::new ;
6215 sub new {
6216     my($class,%att) = @_;
6217
6218     # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
6219
6220     my $this = { %att };
6221     return bless $this, $class;
6222 }
6223
6224 #-> sub CPAN::Distribution::look ;
6225 sub look {
6226     my($self) = @_;
6227
6228     if ($^O eq 'MacOS') {
6229       $self->Mac::BuildTools::look;
6230       return;
6231     }
6232
6233     if (  $CPAN::Config->{'shell'} ) {
6234         $CPAN::Frontend->myprint(qq{
6235 Trying to open a subshell in the build directory...
6236 });
6237     } else {
6238         $CPAN::Frontend->myprint(qq{
6239 Your configuration does not define a value for subshells.
6240 Please define it with "o conf shell <your shell>"
6241 });
6242         return;
6243     }
6244     my $dist = $self->id;
6245     my $dir;
6246     unless ($dir = $self->dir) {
6247         $self->get;
6248     }
6249     unless ($dir ||= $self->dir) {
6250         $CPAN::Frontend->mywarn(qq{
6251 Could not determine which directory to use for looking at $dist.
6252 });
6253         return;
6254     }
6255     my $pwd  = CPAN::anycwd();
6256     $self->safe_chdir($dir);
6257     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
6258     {
6259         local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
6260         $ENV{CPAN_SHELL_LEVEL} += 1;
6261         my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'});
6262         unless (system($shell) == 0) {
6263             my $code = $? >> 8;
6264             $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
6265         }
6266     }
6267     $self->safe_chdir($pwd);
6268 }
6269
6270 # CPAN::Distribution::cvs_import ;
6271 sub cvs_import {
6272     my($self) = @_;
6273     $self->get;
6274     my $dir = $self->dir;
6275
6276     my $package = $self->called_for;
6277     my $module = $CPAN::META->instance('CPAN::Module', $package);
6278     my $version = $module->cpan_version;
6279
6280     my $userid = $self->cpan_userid;
6281
6282     my $cvs_dir = (split /\//, $dir)[-1];
6283     $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
6284     my $cvs_root =
6285       $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
6286     my $cvs_site_perl =
6287       $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
6288     if ($cvs_site_perl) {
6289         $cvs_dir = "$cvs_site_perl/$cvs_dir";
6290     }
6291     my $cvs_log = qq{"imported $package $version sources"};
6292     $version =~ s/\./_/g;
6293     # XXX cvs: undocumented and unclear how it was meant to work
6294     my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
6295                "$cvs_dir", $userid, "v$version");
6296
6297     my $pwd  = CPAN::anycwd();
6298     chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
6299
6300     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
6301
6302     $CPAN::Frontend->myprint(qq{@cmd\n});
6303     system(@cmd) == 0 or
6304     # XXX cvs
6305         $CPAN::Frontend->mydie("cvs import failed");
6306     chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
6307 }
6308
6309 #-> sub CPAN::Distribution::readme ;
6310 sub readme {
6311     my($self) = @_;
6312     my($dist) = $self->id;
6313     my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
6314     $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
6315     my($local_file);
6316     my($local_wanted) =
6317          File::Spec->catfile(
6318                              $CPAN::Config->{keep_source_where},
6319                              "authors",
6320                              "id",
6321                              split(/\//,"$sans.readme"),
6322                             );
6323     $self->debug("Doing localize") if $CPAN::DEBUG;
6324     $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
6325                                       $local_wanted)
6326         or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
6327
6328     if ($^O eq 'MacOS') {
6329         Mac::BuildTools::launch_file($local_file);
6330         return;
6331     }
6332
6333     my $fh_pager = FileHandle->new;
6334     local($SIG{PIPE}) = "IGNORE";
6335     my $pager = $CPAN::Config->{'pager'} || "cat";
6336     $fh_pager->open("|$pager")
6337         or die "Could not open pager $pager\: $!";
6338     my $fh_readme = FileHandle->new;
6339     $fh_readme->open($local_file)
6340         or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
6341     $CPAN::Frontend->myprint(qq{
6342 Displaying file
6343   $local_file
6344 with pager "$pager"
6345 });
6346     $fh_pager->print(<$fh_readme>);
6347     $fh_pager->close;
6348 }
6349
6350 #-> sub CPAN::Distribution::verifyCHECKSUM ;
6351 sub verifyCHECKSUM {
6352     my($self) = @_;
6353   EXCUSE: {
6354         my @e;
6355         $self->{CHECKSUM_STATUS} ||= "";
6356         $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
6357         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
6358     }
6359     my($lc_want,$lc_file,@local,$basename);
6360     @local = split(/\//,$self->id);
6361     pop @local;
6362     push @local, "CHECKSUMS";
6363     $lc_want =
6364         File::Spec->catfile($CPAN::Config->{keep_source_where},
6365                             "authors", "id", @local);
6366     local($") = "/";
6367     if (my $size = -s $lc_want) {
6368         $self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG;
6369         if ($self->CHECKSUM_check_file($lc_want,1)) {
6370             return $self->{CHECKSUM_STATUS} = "OK";
6371         }
6372     }
6373     $lc_file = CPAN::FTP->localize("authors/id/@local",
6374                                    $lc_want,1);
6375     unless ($lc_file) {
6376         $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
6377         $local[-1] .= ".gz";
6378         $lc_file = CPAN::FTP->localize("authors/id/@local",
6379                                        "$lc_want.gz",1);
6380         if ($lc_file) {
6381             $lc_file =~ s/\.gz(?!\n)\Z//;
6382             eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
6383         } else {
6384             return;
6385         }
6386     }
6387     if ($self->CHECKSUM_check_file($lc_file)) {
6388         return $self->{CHECKSUM_STATUS} = "OK";
6389     }
6390 }
6391
6392 #-> sub CPAN::Distribution::SIG_check_file ;
6393 sub SIG_check_file {
6394     my($self,$chk_file) = @_;
6395     my $rv = eval { Module::Signature::_verify($chk_file) };
6396
6397     if ($rv == Module::Signature::SIGNATURE_OK()) {
6398         $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
6399         return $self->{SIG_STATUS} = "OK";
6400     } else {
6401         $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
6402                                  qq{distribution file. }.
6403                                  qq{Please investigate.\n\n}.
6404                                  $self->as_string,
6405                                 $CPAN::META->instance(
6406                                                         'CPAN::Author',
6407                                                         $self->cpan_userid
6408                                                         )->as_string);
6409
6410         my $wrap = qq{I\'d recommend removing $chk_file. Its signature
6411 is invalid. Maybe you have configured your 'urllist' with
6412 a bad URL. Please check this array with 'o conf urllist', and
6413 retry.};
6414
6415         $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
6416     }
6417 }
6418
6419 #-> sub CPAN::Distribution::CHECKSUM_check_file ;
6420
6421 # sloppy is 1 when we have an old checksums file that maybe is good
6422 # enough
6423
6424 sub CHECKSUM_check_file {
6425     my($self,$chk_file,$sloppy) = @_;
6426     my($cksum,$file,$basename);
6427
6428     $sloppy ||= 0;
6429     $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG;
6430     my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
6431                                                       q{check_sigs});
6432     if ($check_sigs) {
6433         if ($CPAN::META->has_inst("Module::Signature")) {
6434             $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
6435             $self->SIG_check_file($chk_file);
6436         } else {
6437             $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
6438         }
6439     }
6440
6441     $file = $self->{localfile};
6442     $basename = File::Basename::basename($file);
6443     my $fh = FileHandle->new;
6444     if (open $fh, $chk_file){
6445         local($/);
6446         my $eval = <$fh>;
6447         $eval =~ s/\015?\012/\n/g;
6448         close $fh;
6449         my($comp) = Safe->new();
6450         $cksum = $comp->reval($eval);
6451         if ($@) {
6452             rename $chk_file, "$chk_file.bad";
6453             Carp::confess($@) if $@;
6454         }
6455     } else {
6456         Carp::carp "Could not open $chk_file for reading";
6457     }
6458
6459     if (! ref $cksum or ref $cksum ne "HASH") {
6460         $CPAN::Frontend->mywarn(qq{
6461 Warning: checksum file '$chk_file' broken.
6462
6463 When trying to read that file I expected to get a hash reference
6464 for further processing, but got garbage instead.
6465 });
6466         my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
6467         $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
6468         $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken";
6469         return;
6470     } elsif (exists $cksum->{$basename}{sha256}) {
6471         $self->debug("Found checksum for $basename:" .
6472                      "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
6473
6474         open($fh, $file);
6475         binmode $fh;
6476         my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
6477         $fh->close;
6478         $fh = CPAN::Tarzip->TIEHANDLE($file);
6479
6480         unless ($eq) {
6481           my $dg = Digest::SHA->new(256);
6482           my($data,$ref);
6483           $ref = \$data;
6484           while ($fh->READ($ref, 4096) > 0){
6485             $dg->add($data);
6486           }
6487           my $hexdigest = $dg->hexdigest;
6488           $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
6489         }
6490
6491         if ($eq) {
6492           $CPAN::Frontend->myprint("Checksum for $file ok\n");
6493           return $self->{CHECKSUM_STATUS} = "OK";
6494         } else {
6495             $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
6496                                      qq{distribution file. }.
6497                                      qq{Please investigate.\n\n}.
6498                                      $self->as_string,
6499                                      $CPAN::META->instance(
6500                                                            'CPAN::Author',
6501                                                            $self->cpan_userid
6502                                                           )->as_string);
6503
6504             my $wrap = qq{I\'d recommend removing $file. Its
6505 checksum is incorrect. Maybe you have configured your 'urllist' with
6506 a bad URL. Please check this array with 'o conf urllist', and
6507 retry.};
6508
6509             $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
6510
6511             # former versions just returned here but this seems a
6512             # serious threat that deserves a die
6513
6514             # $CPAN::Frontend->myprint("\n\n");
6515             # sleep 3;
6516             # return;
6517         }
6518         # close $fh if fileno($fh);
6519     } else {
6520         return if $sloppy;
6521         unless ($self->{CHECKSUM_STATUS}) {
6522             $CPAN::Frontend->mywarn(qq{
6523 Warning: No checksum for $basename in $chk_file.
6524
6525 The cause for this may be that the file is very new and the checksum
6526 has not yet been calculated, but it may also be that something is
6527 going awry right now.
6528 });
6529             my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes");
6530             $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
6531         }
6532         $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file";
6533         return;
6534     }
6535 }
6536
6537 #-> sub CPAN::Distribution::eq_CHECKSUM ;
6538 sub eq_CHECKSUM {
6539     my($self,$fh,$expect) = @_;
6540     if ($CPAN::META->has_inst("Digest::SHA")) {
6541         my $dg = Digest::SHA->new(256);
6542         my($data);
6543         while (read($fh, $data, 4096)){
6544             $dg->add($data);
6545         }
6546         my $hexdigest = $dg->hexdigest;
6547         # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
6548         return $hexdigest eq $expect;
6549     }
6550     return 1;
6551 }
6552
6553 #-> sub CPAN::Distribution::force ;
6554
6555 # Both CPAN::Modules and CPAN::Distributions know if "force" is in
6556 # effect by autoinspection, not by inspecting a global variable. One
6557 # of the reason why this was chosen to work that way was the treatment
6558 # of dependencies. They should not automatically inherit the force
6559 # status. But this has the downside that ^C and die() will return to
6560 # the prompt but will not be able to reset the force_update
6561 # attributes. We try to correct for it currently in the read_metadata
6562 # routine, and immediately before we check for a Signal. I hope this
6563 # works out in one of v1.57_53ff
6564
6565 # "Force get forgets previous error conditions"
6566
6567 #-> sub CPAN::Distribution::fforce ;
6568 sub fforce {
6569   my($self, $method) = @_;
6570   $self->force($method,1);
6571 }
6572
6573 #-> sub CPAN::Distribution::force ;
6574 sub force {
6575   my($self, $method,$fforce) = @_;
6576   my %phase_map = (
6577                    get => [
6578                            "unwrapped",
6579                            "build_dir",
6580                            "archived",
6581                            "localfile",
6582                            "CHECKSUM_STATUS",
6583                            "signature_verify",
6584                            "prefs",
6585                            "prefs_file",
6586                            "prefs_file_doc",
6587                           ],
6588                    make => [
6589                             "writemakefile",
6590                             "make",
6591                             "modulebuild",
6592                             "prereq_pm",
6593                             "prereq_pm_detected",
6594                            ],
6595                    test => [
6596                             "badtestcnt",
6597                             "make_test",
6598                            ],
6599                    install => [
6600                                "install",
6601                               ],
6602                    unknown => [
6603                                "reqtype",
6604                                "yaml_content",
6605                               ],
6606                   );
6607   my $methodmatch = 0;
6608   my $ldebug = 0;
6609  PHASE: for my $phase (qw(unknown get make test install)) { # order matters
6610       $methodmatch = 1 if $fforce || $phase eq $method;
6611       next unless $methodmatch;
6612     ATTRIBUTE: for my $att (@{$phase_map{$phase}}) {
6613           if ($phase eq "get") {
6614               if (substr($self->id,-1,1) eq "."
6615                   && $att =~ /(unwrapped|build_dir|archived)/ ) {
6616                   # cannot be undone for local distros
6617                   next ATTRIBUTE;
6618               }
6619               if ($att eq "build_dir"
6620                   && $self->{build_dir}
6621                   && $CPAN::META->{is_tested}
6622                  ) {
6623                   delete $CPAN::META->{is_tested}{$self->{build_dir}};
6624               }
6625           } elsif ($phase eq "test") {
6626               if ($att eq "make_test"
6627                   && $self->{make_test}
6628                   && $self->{make_test}{COMMANDID}
6629                   && $self->{make_test}{COMMANDID} == $CPAN::CurrentCommandId
6630                  ) {
6631                   # endless loop too likely
6632                   next ATTRIBUTE;
6633               }
6634           }
6635           delete $self->{$att};
6636           if ($ldebug || $CPAN::DEBUG) {
6637               # local $CPAN::DEBUG = 16; # Distribution
6638               CPAN->debug(sprintf "id[%s]phase[%s]att[%s]", $self->id, $phase, $att);
6639           }
6640       }
6641   }
6642   if ($method && $method =~ /make|test|install/) {
6643     $self->{force_update} = 1; # name should probably have been force_install
6644   }
6645 }
6646
6647 #-> sub CPAN::Distribution::notest ;
6648 sub notest {
6649   my($self, $method) = @_;
6650   # warn "XDEBUG: set notest for $self $method";
6651   $self->{"notest"}++; # name should probably have been force_install
6652 }
6653
6654 #-> sub CPAN::Distribution::unnotest ;
6655 sub unnotest {
6656   my($self) = @_;
6657   # warn "XDEBUG: deleting notest";
6658   delete $self->{'notest'};
6659 }
6660
6661 #-> sub CPAN::Distribution::unforce ;
6662 sub unforce {
6663   my($self) = @_;
6664   delete $self->{force_update};
6665 }
6666
6667 #-> sub CPAN::Distribution::isa_perl ;
6668 sub isa_perl {
6669   my($self) = @_;
6670   my $file = File::Basename::basename($self->id);
6671   if ($file =~ m{ ^ perl
6672                   -?
6673                   (5)
6674                   ([._-])
6675                   (
6676                    \d{3}(_[0-4][0-9])?
6677                    |
6678                    \d+\.\d+
6679                   )
6680                   \.tar[._-](?:gz|bz2)
6681                   (?!\n)\Z
6682                 }xs){
6683     return "$1.$3";
6684   } elsif ($self->cpan_comment
6685            &&
6686            $self->cpan_comment =~ /isa_perl\(.+?\)/){
6687     return $1;
6688   }
6689 }
6690
6691
6692 #-> sub CPAN::Distribution::perl ;
6693 sub perl {
6694     my ($self) = @_;
6695     if (! $self) {
6696         use Carp qw(carp);
6697         carp __PACKAGE__ . "::perl was called without parameters.";
6698     }
6699     return CPAN::HandleConfig->safe_quote($CPAN::Perl);
6700 }
6701
6702
6703 #-> sub CPAN::Distribution::make ;
6704 sub make {
6705     my($self) = @_;
6706     if (my $goto = $self->prefs->{goto}) {
6707         return $self->goto($goto);
6708     }
6709     my $make = $self->{modulebuild} ? "Build" : "make";
6710     # Emergency brake if they said install Pippi and get newest perl
6711     if ($self->isa_perl) {
6712       if (
6713           $self->called_for ne $self->id &&
6714           ! $self->{force_update}
6715          ) {
6716         # if we die here, we break bundles
6717         $CPAN::Frontend
6718             ->mywarn(sprintf(
6719                              qq{The most recent version "%s" of the module "%s"
6720 is part of the perl-%s distribution. To install that, you need to run
6721   force install %s   --or--
6722   install %s
6723 },
6724                              $CPAN::META->instance(
6725                                                    'CPAN::Module',
6726                                                    $self->called_for
6727                                                   )->cpan_version,
6728                              $self->called_for,
6729                              $self->isa_perl,
6730                              $self->called_for,
6731                              $self->id,
6732                             ));
6733         $self->{make} = CPAN::Distrostatus->new("NO isa perl");
6734         $CPAN::Frontend->mysleep(1);
6735         return;
6736       }
6737     }
6738     $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
6739     $self->get;
6740     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
6741                            ? $ENV{PERL5LIB}
6742                            : ($ENV{PERLLIB} || "");
6743     $CPAN::META->set_perl5lib;
6744     local $ENV{MAKEFLAGS}; # protect us from outer make calls
6745
6746     if ($CPAN::Signal){
6747       delete $self->{force_update};
6748       return;
6749     }
6750
6751     my $builddir;
6752   EXCUSE: {
6753         my @e;
6754         if (!$self->{archived} || $self->{archived} eq "NO") {
6755             push @e, "Is neither a tar nor a zip archive.";
6756         }
6757
6758         if (!$self->{unwrapped}
6759             || (
6760                 UNIVERSAL::can($self->{unwrapped},"failed") ?
6761                 $self->{unwrapped}->failed :
6762                 $self->{unwrapped} =~ /^NO/
6763                )) {
6764             push @e, "Had problems unarchiving. Please build manually";
6765         }
6766
6767         unless ($self->{force_update}) {
6768             exists $self->{signature_verify} and
6769                 (
6770                  UNIVERSAL::can($self->{signature_verify},"failed") ?
6771                  $self->{signature_verify}->failed :
6772                  $self->{signature_verify} =~ /^NO/
6773                 )
6774                 and push @e, "Did not pass the signature test.";
6775         }
6776
6777         if (exists $self->{writemakefile} &&
6778             (
6779              UNIVERSAL::can($self->{writemakefile},"failed") ?
6780              $self->{writemakefile}->failed :
6781              $self->{writemakefile} =~ /^NO/
6782             )) {
6783             # XXX maybe a retry would be in order?
6784             my $err = UNIVERSAL::can($self->{writemakefile},"text") ?
6785                 $self->{writemakefile}->text :
6786                     $self->{writemakefile};
6787             $err =~ s/^NO\s*//;
6788             $err ||= "Had some problem writing Makefile";
6789             $err .= ", won't make";
6790             push @e, $err;
6791         }
6792
6793         defined $self->{make} and push @e,
6794             "Has already been made";
6795
6796         if (exists $self->{later} and length($self->{later})) {
6797             if ($self->unsat_prereq) {
6798                 push @e, $self->{later};
6799 # RT ticket 18438 raises doubts if the deletion of {later} is valid.
6800 # YAML-0.53 triggered the later hodge-podge here, but my margin notes
6801 # are not sufficient to be sure if we really must/may do the delete
6802 # here. SO I accept the suggested patch for now. If we trigger a bug
6803 # again, I must go into deep contemplation about the {later} flag.
6804
6805 #            } else {
6806 #                delete $self->{later};
6807             }
6808         }
6809
6810         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
6811         $builddir = $self->dir or
6812             $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
6813         unless (chdir $builddir) {
6814             push @e, "Couldn't chdir to '$builddir': $!";
6815         }
6816         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
6817     }
6818     if ($CPAN::Signal){
6819       delete $self->{force_update};
6820       return;
6821     }
6822     $CPAN::Frontend->myprint("\n  CPAN.pm: Going to build ".$self->id."\n\n");
6823     $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
6824
6825     if ($^O eq 'MacOS') {
6826         Mac::BuildTools::make($self);
6827         return;
6828     }
6829
6830     my %env;
6831     while (my($k,$v) = each %ENV) {
6832         next unless defined $v;
6833         $env{$k} = $v;
6834     }
6835     local %ENV = %env;
6836     my $system;
6837     if (my $commandline = $self->prefs->{pl}{commandline}) {
6838         $system = $commandline;
6839         $ENV{PERL} = $^X;
6840     } elsif ($self->{'configure'}) {
6841         $system = $self->{'configure'};
6842     } elsif ($self->{modulebuild}) {
6843         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
6844         $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}";
6845     } else {
6846         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
6847         my $switch = "";
6848 # This needs a handler that can be turned on or off:
6849 #       $switch = "-MExtUtils::MakeMaker ".
6850 #           "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
6851 #           if $] > 5.00310;
6852         my $makepl_arg = $self->make_x_arg("pl");
6853         $system = sprintf("%s%s Makefile.PL%s",
6854                           $perl,
6855                           $switch ? " $switch" : "",
6856                           $makepl_arg ? " $makepl_arg" : "",
6857                          );
6858     }
6859     if (my $env = $self->prefs->{pl}{env}) {
6860         for my $e (keys %$env) {
6861             $ENV{$e} = $env->{$e};
6862         }
6863     }
6864     if (exists $self->{writemakefile}) {
6865     } else {
6866         local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
6867         my($ret,$pid);
6868         $@ = "";
6869         my $go_via_alarm;
6870         if ($CPAN::Config->{inactivity_timeout}) {
6871             require Config;
6872             if ($Config::Config{d_alarm}
6873                 &&
6874                 $Config::Config{d_alarm} eq "define"
6875                ) {
6876                 $go_via_alarm++
6877             } else {
6878                 $CPAN::Frontend->mywarn("Warning: you have configured the config ".
6879                                         "variable 'inactivity_timeout' to ".
6880                                         "'$CPAN::Config->{inactivity_timeout}'. But ".
6881                                         "on this machine the system call 'alarm' ".
6882                                         "isn't available. This means that we cannot ".
6883                                         "provide the feature of intercepting long ".
6884                                         "waiting code and will turn this feature off.\n"
6885                                        );
6886                 $CPAN::Config->{inactivity_timeout} = 0;
6887             }
6888         }
6889         if ($go_via_alarm) {
6890             eval {
6891                 alarm $CPAN::Config->{inactivity_timeout};
6892                 local $SIG{CHLD}; # = sub { wait };
6893                 if (defined($pid = fork)) {
6894                     if ($pid) { #parent
6895                         # wait;
6896                         waitpid $pid, 0;
6897                     } else {    #child
6898                         # note, this exec isn't necessary if
6899                         # inactivity_timeout is 0. On the Mac I'd
6900                         # suggest, we set it always to 0.
6901                         exec $system;
6902                     }
6903                 } else {
6904                     $CPAN::Frontend->myprint("Cannot fork: $!");
6905                     return;
6906                 }
6907             };
6908             alarm 0;
6909             if ($@){
6910                 kill 9, $pid;
6911                 waitpid $pid, 0;
6912                 my $err = "$@";
6913                 $CPAN::Frontend->myprint($err);
6914                 $self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
6915                 $@ = "";
6916                 return;
6917             }
6918         } else {
6919             if (my $expect_model = $self->_prefs_with_expect("pl")) {
6920                 $ret = $self->_run_via_expect($system,$expect_model);
6921                 if (! defined $ret
6922                     && $self->{writemakefile}
6923                     && $self->{writemakefile}->failed) {
6924                     # timeout
6925                     return;
6926                 }
6927             } else {
6928                 $ret = system($system);
6929             }
6930             if ($ret != 0) {
6931                 $self->{writemakefile} = CPAN::Distrostatus
6932                     ->new("NO '$system' returned status $ret");
6933                 $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
6934                 $self->store_persistent_state;
6935                 $self->store_persistent_state;
6936                 return;
6937             }
6938         }
6939         if (-f "Makefile" || -f "Build") {
6940           $self->{writemakefile} = CPAN::Distrostatus->new("YES");
6941           delete $self->{make_clean}; # if cleaned before, enable next
6942         } else {
6943           $self->{writemakefile} = CPAN::Distrostatus
6944               ->new(qq{NO -- Unknown reason});
6945         }
6946     }
6947     if ($CPAN::Signal){
6948       delete $self->{force_update};
6949       return;
6950     }
6951     if (my @prereq = $self->unsat_prereq){
6952         if ($prereq[0][0] eq "perl") {
6953             my $need = "requires perl '$prereq[0][1]'";
6954             my $id = $self->pretty_id;
6955             $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
6956             $self->{make} = CPAN::Distrostatus->new("NO $need");
6957             $self->store_persistent_state;
6958             return;
6959         } else {
6960             return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
6961         }
6962     }
6963     if ($CPAN::Signal){
6964       delete $self->{force_update};
6965       return;
6966     }
6967     if (my $commandline = $self->prefs->{make}{commandline}) {
6968         $system = $commandline;
6969         $ENV{PERL} = $^X;
6970     } else {
6971         if ($self->{modulebuild}) {
6972             unless (-f "Build") {
6973                 my $cwd = CPAN::anycwd();
6974                 $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
6975                                         " in cwd[$cwd]. Danger, Will Robinson!");
6976                 $CPAN::Frontend->mysleep(5);
6977             }
6978             $system = join " ", $self->_build_command(), $CPAN::Config->{mbuild_arg};
6979         } else {
6980             $system = join " ", $self->_make_command(),  $CPAN::Config->{make_arg};
6981         }
6982         $system =~ s/\s+$//;
6983         my $make_arg = $self->make_x_arg("make");
6984         $system = sprintf("%s%s",
6985                           $system,
6986                           $make_arg ? " $make_arg" : "",
6987                          );
6988     }
6989     if (my $env = $self->prefs->{make}{env}) { # overriding the local
6990                                                # ENV of PL, not the
6991                                                # outer ENV, but
6992                                                # unlikely to be a risk
6993         for my $e (keys %$env) {
6994             $ENV{$e} = $env->{$e};
6995         }
6996     }
6997     my $expect_model = $self->_prefs_with_expect("make");
6998     my $want_expect = 0;
6999     if ( $expect_model && @{$expect_model->{talk}} ) {
7000         my $can_expect = $CPAN::META->has_inst("Expect");
7001         if ($can_expect) {
7002             $want_expect = 1;
7003         } else {
7004             $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
7005                                     "system()\n");
7006         }
7007     }
7008     my $system_ok;
7009     if ($want_expect) {
7010         $system_ok = $self->_run_via_expect($system,$expect_model) == 0;
7011     } else {
7012         $system_ok = system($system) == 0;
7013     }
7014     $self->introduce_myself;
7015     if ( $system_ok ) {
7016          $CPAN::Frontend->myprint("  $system -- OK\n");
7017          $self->{make} = CPAN::Distrostatus->new("YES");
7018     } else {
7019          $self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
7020          $self->{make} = CPAN::Distrostatus->new("NO");
7021          $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
7022     }
7023     $self->store_persistent_state;
7024 }
7025
7026 # CPAN::Distribution::_run_via_expect
7027 sub _run_via_expect {
7028     my($self,$system,$expect_model) = @_;
7029     CPAN->debug("system[$system]expect_model[$expect_model]") if $CPAN::DEBUG;
7030     if ($CPAN::META->has_inst("Expect")) {
7031         my $expo = Expect->new;  # expo Expect object;
7032         $expo->spawn($system);
7033         $expect_model->{mode} ||= "deterministic";
7034         if ($expect_model->{mode} eq "deterministic") {
7035             return $self->_run_via_expect_deterministic($expo,$expect_model);
7036         } elsif ($expect_model->{mode} eq "anyorder") {
7037             return $self->_run_via_expect_anyorder($expo,$expect_model);
7038         } else {
7039             die "Panic: Illegal expect mode: $expect_model->{mode}";
7040         }
7041     } else {
7042         $CPAN::Frontend->mywarn("Expect not installed, falling back to system()\n");
7043         return system($system);
7044     }
7045 }
7046
7047 sub _run_via_expect_anyorder {
7048     my($self,$expo,$expect_model) = @_;
7049     my $timeout = $expect_model->{timeout} || 5;
7050     my @expectacopy = @{$expect_model->{talk}}; # we trash it!
7051     my $but = "";
7052   EXPECT: while () {
7053         my($eof,$ran_into_timeout);
7054         my @match = $expo->expect($timeout,
7055                                   [ eof => sub {
7056                                         $eof++;
7057                                     } ],
7058                                   [ timeout => sub {
7059                                         $ran_into_timeout++;
7060                                     } ],
7061                                   -re => eval"qr{.}",
7062                                  );
7063         if ($match[2]) {
7064             $but .= $match[2];
7065         }
7066         $but .= $expo->clear_accum;
7067         if ($eof) {
7068             $expo->soft_close;
7069             return $expo->exitstatus();
7070         } elsif ($ran_into_timeout) {
7071             # warn "DEBUG: they are asking a question, but[$but]";
7072             for (my $i = 0; $i <= $#expectacopy; $i+=2) {
7073                 my($next,$send) = @expectacopy[$i,$i+1];
7074                 my $regex = eval "qr{$next}";
7075                 # warn "DEBUG: will compare with regex[$regex].";
7076                 if ($but =~ /$regex/) {
7077                     # warn "DEBUG: will send send[$send]";
7078                     $expo->send($send);
7079                     splice @expectacopy, $i, 2; # never allow reusing an QA pair
7080                     next EXPECT;
7081                 }
7082             }
7083             my $why = "could not answer a question during the dialog";
7084             $CPAN::Frontend->mywarn("Failing: $why\n");
7085             $self->{writemakefile} =
7086                 CPAN::Distrostatus->new("NO $why");
7087             return;
7088         }
7089     }
7090 }
7091
7092 sub _run_via_expect_deterministic {
7093     my($self,$expo,$expect_model) = @_;
7094     my $ran_into_timeout;
7095     my $timeout = $expect_model->{timeout} || 15; # currently unsettable
7096     my $expecta = $expect_model->{talk};
7097   EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) {
7098         my($re,$send) = @$expecta[$i,$i+1];
7099         CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG;
7100         my $regex = eval "qr{$re}";
7101         $expo->expect($timeout,
7102                       [ eof => sub {
7103                             my $but = $expo->clear_accum;
7104                             $CPAN::Frontend->mywarn("EOF (maybe harmless)
7105 expected[$regex]\nbut[$but]\n\n");
7106                             last EXPECT;
7107                         } ],
7108                       [ timeout => sub {
7109                             my $but = $expo->clear_accum;
7110                             $CPAN::Frontend->mywarn("TIMEOUT
7111 expected[$regex]\nbut[$but]\n\n");
7112                             $ran_into_timeout++;
7113                         } ],
7114                       -re => $regex);
7115         if ($ran_into_timeout){
7116             # note that the caller expects 0 for success
7117             $self->{writemakefile} =
7118                 CPAN::Distrostatus->new("NO timeout during expect dialog");
7119             return;
7120         }
7121         $expo->send($send);
7122     }
7123     $expo->soft_close;
7124     return $expo->exitstatus();
7125 }
7126
7127 #-> CPAN::Distribution::_validate_distropref
7128 sub _validate_distropref {
7129     my($self,@args) = @_;
7130     if (
7131         $CPAN::META->has_inst("CPAN::Kwalify")
7132         &&
7133         $CPAN::META->has_inst("Kwalify")
7134        ) {
7135         eval {CPAN::Kwalify::_validate("distroprefs",@args);};
7136         if ($@) {
7137             $CPAN::Frontend->mywarn($@);
7138         }
7139     } else {
7140         CPAN->debug("not validating '@args'") if $CPAN::DEBUG;
7141     }
7142 }
7143
7144 #-> CPAN::Distribution::_find_prefs
7145 sub _find_prefs {
7146     my($self) = @_;
7147     my $distroid = $self->pretty_id;
7148     #CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG;
7149     my $prefs_dir = $CPAN::Config->{prefs_dir};
7150     eval { File::Path::mkpath($prefs_dir); };
7151     if ($@) {
7152         $CPAN::Frontend->mydie("Cannot create directory $prefs_dir");
7153     }
7154     my $yaml_module = CPAN::_yaml_module;
7155     my @extensions;
7156     if ($CPAN::META->has_inst($yaml_module)) {
7157         push @extensions, "yml";
7158     } else {
7159         my @fallbacks;
7160         if ($CPAN::META->has_inst("Data::Dumper")) {
7161             push @extensions, "dd";
7162             push @fallbacks, "Data::Dumper";
7163         }
7164         if ($CPAN::META->has_inst("Storable")) {
7165             push @extensions, "st";
7166             push @fallbacks, "Storable";
7167         }
7168         if (@fallbacks) {
7169             local $" = " and ";
7170             unless ($self->{have_complained_about_missing_yaml}++) {
7171                 $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back ".
7172                                         "to @fallbacks to read prefs '$prefs_dir'\n");
7173             }
7174         } else {
7175             unless ($self->{have_complained_about_missing_yaml}++) {
7176                 $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot ".
7177                                         "read prefs '$prefs_dir'\n");
7178             }
7179         }
7180     }
7181     if (@extensions) {
7182         my $dh = DirHandle->new($prefs_dir)
7183             or die Carp::croak("Couldn't open '$prefs_dir': $!");
7184       DIRENT: for (sort $dh->read) {
7185             next if $_ eq "." || $_ eq "..";
7186             my $exte = join "|", @extensions;
7187             next unless /\.($exte)$/;
7188             my $thisexte = $1;
7189             my $abs = File::Spec->catfile($prefs_dir, $_);
7190             if (-f $abs) {
7191                 #CPAN->debug(sprintf "abs[%s]", $abs) if $CPAN::DEBUG;
7192                 my @distropref;
7193                 if ($thisexte eq "yml") {
7194                     # need no eval because if we have no YAML we do not try to read *.yml
7195                     #CPAN->debug(sprintf "before yaml load abs[%s]", $abs) if $CPAN::DEBUG;
7196                     @distropref = @{CPAN->_yaml_loadfile($abs)};
7197                     #CPAN->debug(sprintf "after yaml load abs[%s]", $abs) if $CPAN::DEBUG;
7198                 } elsif ($thisexte eq "dd") {
7199                     package CPAN::Eval;
7200                     no strict;
7201                     open FH, "<$abs" or $CPAN::Frontend->mydie("Could not open '$abs': $!");
7202                     local $/;
7203                     my $eval = <FH>;
7204                     close FH;
7205                     eval $eval;
7206                     if ($@) {
7207                         $CPAN::Frontend->mydie("Error in distroprefs file $_\: $@");
7208                     }
7209                     my $i = 1;
7210                     while (${"VAR".$i}) {
7211                         push @distropref, ${"VAR".$i};
7212                         $i++;
7213                     }
7214                 } elsif ($thisexte eq "st") {
7215                     # eval because Storable is never forward compatible
7216                     eval { @distropref = @{scalar Storable::retrieve($abs)}; };
7217                     if ($@) {
7218                         $CPAN::Frontend->mywarn("Error reading distroprefs file ".
7219                                                 "$_, skipping\: $@");
7220                         $CPAN::Frontend->mysleep(4);
7221                         next DIRENT;
7222                     }
7223                 }
7224                 # $DB::single=1;
7225                 #CPAN->debug(sprintf "#distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
7226               ELEMENT: for my $y (0..$#distropref) {
7227                     my $distropref = $distropref[$y];
7228                     $self->_validate_distropref($distropref,$abs,$y);
7229                     my $match = $distropref->{match};
7230                     unless ($match) {
7231                         #CPAN->debug("no 'match' in abs[$abs], skipping") if $CPAN::DEBUG;
7232                         next ELEMENT;
7233                     }
7234                     my $ok = 1;
7235                     # do not take the order of C<keys %$match> because
7236                     # "module" is by far the slowest
7237                     for my $sub_attribute (qw(distribution perl module)) {
7238                         next unless exists $match->{$sub_attribute};
7239                         my $qr = eval "qr{$distropref->{match}{$sub_attribute}}";
7240                         if ($sub_attribute eq "module") {
7241                             my $okm = 0;
7242                             #CPAN->debug(sprintf "distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
7243                             my @modules = $self->containsmods;
7244                             #CPAN->debug(sprintf "modules[%s]", join(",",@modules)) if $CPAN::DEBUG;
7245                           MODULE: for my $module (@modules) {
7246                                 $okm ||= $module =~ /$qr/;
7247                                 last MODULE if $okm;
7248                             }
7249                             $ok &&= $okm;
7250                         } elsif ($sub_attribute eq "distribution") {
7251                             my $okd = $distroid =~ /$qr/;
7252                             $ok &&= $okd;
7253                         } elsif ($sub_attribute eq "perl") {
7254                             my $okp = $^X =~ /$qr/;
7255                             $ok &&= $okp;
7256                         } else {
7257                             $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ".
7258                                                    "unknown sub_attribut '$sub_attribute'. ".
7259                                                    "Please ".
7260                                                    "remove, cannot continue.");
7261                         }
7262                         last if $ok == 0; # short circuit
7263                     }
7264                     #CPAN->debug(sprintf "ok[%d]", $ok) if $CPAN::DEBUG;
7265                     if ($ok) {
7266                         return {
7267                                 prefs => $distropref,
7268                                 prefs_file => $abs,
7269                                 prefs_file_doc => $y,
7270                                };
7271                     }
7272
7273                 }
7274             }
7275         }
7276         $dh->close;
7277     }
7278     return;
7279 }
7280
7281 # CPAN::Distribution::prefs
7282 sub prefs {
7283     my($self) = @_;
7284     if (exists $self->{negative_prefs_cache}
7285         &&
7286         $self->{negative_prefs_cache} != $CPAN::CurrentCommandId
7287        ) {
7288         delete $self->{negative_prefs_cache};
7289         delete $self->{prefs};
7290     }
7291     if (exists $self->{prefs}) {
7292         return $self->{prefs}; # XXX comment out during debugging
7293     }
7294     if ($CPAN::Config->{prefs_dir}) {
7295         CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG;
7296         my $prefs = $self->_find_prefs();
7297         $prefs ||= ""; # avoid warning next line
7298         CPAN->debug("prefs[$prefs]") if $CPAN::DEBUG;
7299         if ($prefs) {
7300             for my $x (qw(prefs prefs_file prefs_file_doc)) {
7301                 $self->{$x} = $prefs->{$x};
7302             }
7303             my $bs = sprintf(
7304                              "%s[%s]",
7305                              File::Basename::basename($self->{prefs_file}),
7306                              $self->{prefs_file_doc},
7307                             );
7308             my $filler1 = "_" x 22;
7309             my $filler2 = int(66 - length($bs))/2;
7310             $filler2 = 0 if $filler2 < 0;
7311             $filler2 = " " x $filler2;
7312             $CPAN::Frontend->myprint("
7313 $filler1 D i s t r o P r e f s $filler1
7314 $filler2 $bs $filler2
7315 ");
7316             $CPAN::Frontend->mysleep(1);
7317             return $self->{prefs};
7318         }
7319     }
7320     $self->{negative_prefs_cache} = $CPAN::CurrentCommandId;
7321     return $self->{prefs} = +{};
7322 }
7323
7324 # CPAN::Distribution::make_x_arg
7325 sub make_x_arg {
7326     my($self, $whixh) = @_;
7327     my $make_x_arg;
7328     my $prefs = $self->prefs;
7329     if (
7330         $prefs
7331         && exists $prefs->{$whixh}
7332         && exists $prefs->{$whixh}{args}
7333         && $prefs->{$whixh}{args}
7334        ) {
7335         $make_x_arg = join(" ",
7336                            map {CPAN::HandleConfig
7337                                  ->safe_quote($_)} @{$prefs->{$whixh}{args}},
7338                           );
7339     }
7340     my $what = sprintf "make%s_arg", $whixh eq "make" ? "" : $whixh;
7341     $make_x_arg ||= $CPAN::Config->{$what};
7342     return $make_x_arg;
7343 }
7344
7345 # CPAN::Distribution::_make_command
7346 sub _make_command {
7347     my ($self) = @_;
7348     if ($self) {
7349         return
7350             CPAN::HandleConfig
7351                 ->safe_quote(
7352                              CPAN::HandleConfig->prefs_lookup($self,
7353                                                               q{make})
7354                              || $Config::Config{make}
7355                              || 'make'
7356                             );
7357     } else {
7358         # Old style call, without object. Deprecated
7359         Carp::confess("CPAN::_make_command() used as function. Don't Do That.");
7360         return
7361           safe_quote(undef,
7362                      CPAN::HandleConfig->prefs_lookup($self,q{make})
7363                      || $CPAN::Config->{make}
7364                      || $Config::Config{make}
7365                      || 'make');
7366     }
7367 }
7368
7369 #-> sub CPAN::Distribution::follow_prereqs ;
7370 sub follow_prereqs {
7371     my($self) = shift;
7372     my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
7373     return unless @prereq_tuples;
7374     my @prereq = map { $_->[0] } @prereq_tuples;
7375     my $pretty_id = $self->pretty_id;
7376     my %map = (
7377                b => "build_requires",
7378                r => "requires",
7379                c => "commandline",
7380               );
7381     my($filler1,$filler2,$filler3,$filler4);
7382     # $DB::single=1;
7383     my $unsat = "Unsatisfied dependencies detected during";
7384     my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id);
7385     {
7386         my $r = int(($w - length($unsat))/2);
7387         my $l = $w - length($unsat) - $r;
7388         $filler1 = "-"x4 . " "x$l;
7389         $filler2 = " "x$r . "-"x4 . "\n";
7390     }
7391     {
7392         my $r = int(($w - length($pretty_id))/2);
7393         my $l = $w - length($pretty_id) - $r;
7394         $filler3 = "-"x4 . " "x$l;
7395         $filler4 = " "x$r . "-"x4 . "\n";
7396     }
7397     $CPAN::Frontend->
7398         myprint("$filler1 $unsat $filler2".
7399                 "$filler3 $pretty_id $filler4".
7400                 join("", map {"    $_->[0] \[$map{$_->[1]}]\n"} @prereq_tuples),
7401                );
7402     my $follow = 0;
7403     if ($CPAN::Config->{prerequisites_policy} eq "follow") {
7404         $follow = 1;
7405     } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
7406         my $answer = CPAN::Shell::colorable_makemaker_prompt(
7407 "Shall I follow them and prepend them to the queue
7408 of modules we are processing right now?", "yes");
7409         $follow = $answer =~ /^\s*y/i;
7410     } else {
7411         local($") = ", ";
7412         $CPAN::Frontend->
7413             myprint("  Ignoring dependencies on modules @prereq\n");
7414     }
7415     if ($follow) {
7416         my $id = $self->id;
7417         # color them as dirty
7418         for my $p (@prereq) {
7419             # warn "calling color_cmd_tmps(0,1)";
7420             my $any = CPAN::Shell->expandany($p);
7421             if ($any) {
7422                 $any->color_cmd_tmps(0,2);
7423             } else {
7424                 $CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$p'\n");
7425                 $CPAN::Frontend->mysleep(2);
7426             }
7427         }
7428         # queue them and re-queue yourself
7429         CPAN::Queue->jumpqueue([$id,$self->{reqtype}],
7430                                reverse @prereq_tuples);
7431         $self->{later} = "Delayed until after prerequisites";
7432         return 1; # signal success to the queuerunner
7433     }
7434 }
7435
7436 #-> sub CPAN::Distribution::unsat_prereq ;
7437 # return ([Foo=>1],[Bar=>1.2]) for normal modules
7438 # return ([perl=>5.008]) if we need a newer perl than we are running under
7439 sub unsat_prereq {
7440     my($self) = @_;
7441     my $prereq_pm = $self->prereq_pm or return;
7442     my(@need);
7443     my %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}});
7444     my @merged = %merged;
7445     CPAN->debug("all merged_prereqs[@merged]") if $CPAN::DEBUG;
7446   NEED: while (my($need_module, $need_version) = each %merged) {
7447         my($available_version,$available_file,$nmo);
7448         if ($need_module eq "perl") {
7449             $available_version = $];
7450             $available_file = $^X;
7451         } else {
7452             $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
7453             next if $nmo->uptodate;
7454             $available_file = $nmo->available_file;
7455
7456             # if they have not specified a version, we accept any installed one
7457             if (not defined $need_version or
7458                 $need_version == 0 or
7459                 $need_version eq "undef") {
7460                 next if defined $available_file;
7461             }
7462
7463             $available_version = $nmo->available_version;
7464         }
7465
7466         # We only want to install prereqs if either they're not installed
7467         # or if the installed version is too old. We cannot omit this
7468         # check, because if 'force' is in effect, nobody else will check.
7469         if (defined $available_file) {
7470             my(@all_requirements) = split /\s*,\s*/, $need_version;
7471             local($^W) = 0;
7472             my $ok = 0;
7473           RQ: for my $rq (@all_requirements) {
7474                 if ($rq =~ s|>=\s*||) {
7475                 } elsif ($rq =~ s|>\s*||) {
7476                     # 2005-12: one user
7477                     if (CPAN::Version->vgt($available_version,$rq)){
7478                         $ok++;
7479                     }
7480                     next RQ;
7481                 } elsif ($rq =~ s|!=\s*||) {
7482                     # 2005-12: no user
7483                     if (CPAN::Version->vcmp($available_version,$rq)){
7484                         $ok++;
7485                         next RQ;
7486                     } else {
7487                         last RQ;
7488                     }
7489                 } elsif ($rq =~ m|<=?\s*|) {
7490                     # 2005-12: no user
7491                     $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n");
7492                     $ok++;
7493                     next RQ;
7494                 }
7495                 if (! CPAN::Version->vgt($rq, $available_version)){
7496                     $ok++;
7497                 }
7498                 CPAN->debug(sprintf("need_module[%s]available_file[%s]".
7499                                     "available_version[%s]rq[%s]ok[%d]",
7500                                     $need_module,
7501                                     $available_file,
7502                                     $available_version,
7503                                     CPAN::Version->readable($rq),
7504                                     $ok,
7505                                    )) if $CPAN::DEBUG;
7506             }
7507             next NEED if $ok == @all_requirements;
7508         }
7509
7510         if ($need_module eq "perl") {
7511             return ["perl", $need_version];
7512         }
7513         if ($self->{sponsored_mods}{$need_module}++){
7514             # We have already sponsored it and for some reason it's still
7515             # not available. So we do ... what??
7516
7517             # if we push it again, we have a potential infinite loop
7518
7519             # The following "next" was a very problematic construct.
7520             # It helped a lot but broke some day and must be replaced.
7521
7522             # We must be able to deal with modules that come again and
7523             # again as a prereq and have themselves prereqs and the
7524             # queue becomes long but finally we would find the correct
7525             # order. The RecursiveDependency check should trigger a
7526             # die when it's becoming too weird. Unfortunately removing
7527             # this next breaks many other things.
7528
7529             # The bug that brought this up is described in Todo under
7530             # "5.8.9 cannot install Compress::Zlib"
7531
7532             # next; # this is the next that must go away
7533
7534             # The following "next NEED" are fine and the error message
7535             # explains well what is going on. For example when the DBI
7536             # fails and consequently DBD::SQLite fails and now we are
7537             # processing CPAN::SQLite. Then we must have a "next" for
7538             # DBD::SQLite. How can we get it and how can we identify
7539             # all other cases we must identify?
7540
7541             my $do = $nmo->distribution;
7542             next NEED unless $do; # not on CPAN
7543           NOSAYER: for my $nosayer (
7544                                     "unwrapped",
7545                                     "writemakefile",
7546                                     "signature_verify",
7547                                     "make",
7548                                     "make_test",
7549                                     "install",
7550                                     "make_clean",
7551                                    ) {
7552                 if (
7553                     $do->{$nosayer}
7554                     &&(UNIVERSAL::can($do->{$nosayer},"failed") ?
7555                        $do->{$nosayer}->failed :
7556                        $do->{$nosayer} =~ /^NO/)
7557                    ) {
7558                     if ($nosayer eq "make_test"
7559                         &&
7560                         $do->{make_test}{COMMANDID} != $CPAN::CurrentCommandId
7561                        ) {
7562                         next NOSAYER;
7563                     }
7564                     $CPAN::Frontend->mywarn("Warning: Prerequisite ".
7565                                             "'$need_module => $need_version' ".
7566                                             "for '$self->{ID}' failed when ".
7567                                             "processing '$do->{ID}' with ".
7568                                             "'$nosayer => $do->{$nosayer}'. Continuing, ".
7569                                             "but chances to succeed are limited.\n"
7570                                            );
7571                     next NEED;
7572                 }
7573             }
7574         }
7575         my $needed_as = exists $prereq_pm->{requires}{$need_module} ? "r" : "b";
7576         push @need, [$need_module,$needed_as];
7577     }
7578     my @unfolded = map { "[".join(",",@$_)."]" } @need;
7579     CPAN->debug("returning from unsat_prereq[@unfolded]") if $CPAN::DEBUG;
7580     @need;
7581 }
7582
7583 #-> sub CPAN::Distribution::read_yaml ;
7584 sub read_yaml {
7585     my($self) = @_;
7586     return $self->{yaml_content} if exists $self->{yaml_content};
7587     my $build_dir = $self->{build_dir};
7588     my $yaml = File::Spec->catfile($build_dir,"META.yml");
7589     $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
7590     return unless -f $yaml;
7591     eval { $self->{yaml_content} = CPAN->_yaml_loadfile($yaml)->[0]; };
7592     if ($@) {
7593         $CPAN::Frontend->mywarn("Could not read ".
7594                                 "'$yaml'. Falling back to other ".
7595                                 "methods to determine prerequisites\n");
7596         return $self->{yaml_content} = undef; # if we die, then we
7597                                               # cannot read YAML's own
7598                                               # META.yml
7599     }
7600     # not "authoritative"
7601     if (not exists $self->{yaml_content}{dynamic_config}
7602         or $self->{yaml_content}{dynamic_config}
7603        ) {
7604         $self->{yaml_content} = undef;
7605     }
7606     $self->debug(sprintf "yaml_content[%s]", $self->{yaml_content} || "UNDEF")
7607         if $CPAN::DEBUG;
7608     return $self->{yaml_content};
7609 }
7610
7611 #-> sub CPAN::Distribution::prereq_pm ;
7612 sub prereq_pm {
7613     my($self) = @_;
7614     $self->{prereq_pm_detected} ||= 0;
7615     CPAN->debug("ID[$self->{ID}]prereq_pm_detected[$self->{prereq_pm_detected}]") if $CPAN::DEBUG;
7616     return $self->{prereq_pm} if $self->{prereq_pm_detected};
7617     return unless $self->{writemakefile}  # no need to have succeeded
7618                                           # but we must have run it
7619         || $self->{modulebuild};
7620     CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
7621                 $self->{writemakefile}||"",
7622                 $self->{modulebuild}||"",
7623                ) if $CPAN::DEBUG;
7624     my($req,$breq);
7625     if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
7626         $req =  $yaml->{requires} || {};
7627         $breq =  $yaml->{build_requires} || {};
7628         undef $req unless ref $req eq "HASH" && %$req;
7629         if ($req) {
7630             if ($yaml->{generated_by} &&
7631                 $yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
7632                 my $eummv = do { local $^W = 0; $1+0; };
7633                 if ($eummv < 6.2501) {
7634                     # thanks to Slaven for digging that out: MM before
7635                     # that could be wrong because it could reflect a
7636                     # previous release
7637                     undef $req;
7638                 }
7639             }
7640             my $areq;
7641             my $do_replace;
7642             while (my($k,$v) = each %{$req||{}}) {
7643                 if ($v =~ /\d/) {
7644                     $areq->{$k} = $v;
7645                 } elsif ($k =~ /[A-Za-z]/ &&
7646                          $v =~ /[A-Za-z]/ &&
7647                          $CPAN::META->exists("Module",$v)
7648                         ) {
7649                     $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
7650                                             "requires hash: $k => $v; I'll take both ".
7651                                             "key and value as a module name\n");
7652                     $CPAN::Frontend->mysleep(1);
7653                     $areq->{$k} = 0;
7654                     $areq->{$v} = 0;
7655                     $do_replace++;
7656                 }
7657             }
7658             $req = $areq if $do_replace;
7659         }
7660     }
7661     unless ($req || $breq) {
7662         my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
7663         my $makefile = File::Spec->catfile($build_dir,"Makefile");
7664         my $fh;
7665         if (-f $makefile
7666             and
7667             $fh = FileHandle->new("<$makefile\0")) {
7668             CPAN->debug("Getting prereq from Makefile") if $CPAN::DEBUG;
7669             local($/) = "\n";
7670             while (<$fh>) {
7671                 last if /MakeMaker post_initialize section/;
7672                 my($p) = m{^[\#]
7673                            \s+PREREQ_PM\s+=>\s+(.+)
7674                        }x;
7675                 next unless $p;
7676                 # warn "Found prereq expr[$p]";
7677
7678                 #  Regexp modified by A.Speer to remember actual version of file
7679                 #  PREREQ_PM hash key wants, then add to
7680                 while ( $p =~ m/(?:\s)([\w\:]+)=>(q\[.*?\]|undef),?/g ){
7681                     # In case a prereq is mentioned twice, complain.
7682                     if ( defined $req->{$1} ) {
7683                         warn "Warning: PREREQ_PM mentions $1 more than once, ".
7684                             "last mention wins";
7685                     }
7686                     my($m,$n) = ($1,$2);
7687                     if ($n =~ /^q\[(.*?)\]$/) {
7688                         $n = $1;
7689                     }
7690                     $req->{$m} = $n;
7691                 }
7692                 last;
7693             }
7694         }
7695     }
7696     unless ($req || $breq) {
7697         my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
7698         my $buildfile = File::Spec->catfile($build_dir,"Build");
7699         if (-f $buildfile) {
7700             CPAN->debug("Found '$buildfile'") if $CPAN::DEBUG;
7701             my $build_prereqs = File::Spec->catfile($build_dir,"_build","prereqs");
7702             if (-f $build_prereqs) {
7703                 CPAN->debug("Getting prerequisites from '$build_prereqs'") if $CPAN::DEBUG;
7704                 my $content = do { local *FH;
7705                                    open FH, $build_prereqs
7706                                        or $CPAN::Frontend->mydie("Could not open ".
7707                                                                  "'$build_prereqs': $!");
7708                                    local $/;
7709                                    <FH>;
7710                                };
7711                 my $bphash = eval $content;
7712                 if ($@) {
7713                 } else {
7714                     $req  = $bphash->{requires} || +{};
7715                     $breq = $bphash->{build_requires} || +{};
7716                 }
7717             }
7718         }
7719     }
7720     if (-f "Build.PL"
7721         && ! -f "Makefile.PL"
7722         && ! exists $req->{"Module::Build"}
7723         && ! $CPAN::META->has_inst("Module::Build")) {
7724         $CPAN::Frontend->mywarn("  Warning: CPAN.pm discovered Module::Build as ".
7725                                 "undeclared prerequisite.\n".
7726                                 "  Adding it now as such.\n"
7727                                );
7728         $CPAN::Frontend->mysleep(5);
7729         $req->{"Module::Build"} = 0;
7730         delete $self->{writemakefile};
7731     }
7732     if ($req || $breq) {
7733         $self->{prereq_pm_detected}++;
7734         return $self->{prereq_pm} = { requires => $req, build_requires => $breq };
7735     }
7736 }
7737
7738 #-> sub CPAN::Distribution::test ;
7739 sub test {
7740     my($self) = @_;
7741     if (my $goto = $self->prefs->{goto}) {
7742         return $self->goto($goto);
7743     }
7744     $self->make;
7745     if ($CPAN::Signal){
7746       delete $self->{force_update};
7747       return;
7748     }
7749     # warn "XDEBUG: checking for notest: $self->{notest} $self";
7750     if ($self->{notest}) {
7751         $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
7752         return 1;
7753     }
7754
7755     my $make = $self->{modulebuild} ? "Build" : "make";
7756
7757     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
7758                            ? $ENV{PERL5LIB}
7759                            : ($ENV{PERLLIB} || "");
7760
7761     $CPAN::META->set_perl5lib;
7762     local $ENV{MAKEFLAGS}; # protect us from outer make calls
7763
7764     $CPAN::Frontend->myprint("Running $make test\n");
7765
7766 #    if (my @prereq = $self->unsat_prereq){
7767 #        if ( $CPAN::DEBUG ) {
7768 #            require Data::Dumper;
7769 #            CPAN->debug(sprintf "unsat_prereq[%s]", Data::Dumper::Dumper(\@prereq));
7770 #        }
7771 #        unless ($prereq[0][0] eq "perl") {
7772 #            return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
7773 #        }
7774 #    }
7775
7776   EXCUSE: {
7777         my @e;
7778         unless (exists $self->{make} or exists $self->{later}) {
7779             push @e,
7780                 "Make had some problems, won't test";
7781         }
7782
7783         exists $self->{make} and
7784             (
7785              UNIVERSAL::can($self->{make},"failed") ?
7786              $self->{make}->failed :
7787              $self->{make} =~ /^NO/
7788             ) and push @e, "Can't test without successful make";
7789
7790         $self->{badtestcnt} ||= 0;
7791         if ($self->{badtestcnt} > 0) {
7792             require Data::Dumper;
7793             CPAN->debug(sprintf "NOREPEAT[%s]", Data::Dumper::Dumper($self)) if $CPAN::DEBUG;
7794             push @e, "Won't repeat unsuccessful test during this command";
7795         }
7796
7797         exists $self->{later} and length($self->{later}) and
7798             push @e, $self->{later};
7799
7800         if (exists $self->{build_dir}) {
7801             if ($CPAN::META->{is_tested}{$self->{build_dir}}
7802                 &&
7803                 exists $self->{make_test}
7804                 &&
7805                 !(
7806                   UNIVERSAL::can($self->{make_test},"failed") ?
7807                   $self->{make_test}->failed :
7808                   $self->{make_test} =~ /^NO/
7809                  )
7810                ) {
7811                 push @e, "Has already been tested successfully";
7812             }
7813         } elsif (!@e) {
7814             push @e, "Has no own directory";
7815         }
7816         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
7817         unless (chdir $self->{build_dir}) {
7818             push @e, "Couldn't chdir to '$self->{build_dir}': $!";
7819         }
7820         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
7821     }
7822     $self->debug("Changed directory to $self->{build_dir}")
7823         if $CPAN::DEBUG;
7824
7825     if ($^O eq 'MacOS') {
7826         Mac::BuildTools::make_test($self);
7827         return;
7828     }
7829
7830     if ($self->{modulebuild}) {
7831         my $v = CPAN::Shell->expand("Module","Test::Harness")->inst_version;
7832         if (CPAN::Version->vlt($v,2.62)) {
7833             $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
7834   '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n});
7835             $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old");
7836             return;
7837         }
7838     }
7839
7840     my $system;
7841     if (my $commandline = $self->prefs->{test}{commandline}) {
7842         $system = $commandline;
7843         $ENV{PERL} = $^X;
7844     } elsif ($self->{modulebuild}) {
7845         $system = sprintf "%s test", $self->_build_command();
7846     } else {
7847         $system = join " ", $self->_make_command(), "test";
7848     }
7849     my $make_test_arg = $self->make_x_arg("test");
7850     $system = sprintf("%s%s",
7851                       $system,
7852                       $make_test_arg ? " $make_test_arg" : "",
7853                      );
7854     my($tests_ok);
7855     my %env;
7856     while (my($k,$v) = each %ENV) {
7857         next unless defined $v;
7858         $env{$k} = $v;
7859     }
7860     local %ENV = %env;
7861     if (my $env = $self->prefs->{test}{env}) {
7862         for my $e (keys %$env) {
7863             $ENV{$e} = $env->{$e};
7864         }
7865     }
7866     my $expect_model = $self->_prefs_with_expect("test");
7867     my $want_expect = 0;
7868     if ( $expect_model && @{$expect_model->{talk}} ) {
7869         my $can_expect = $CPAN::META->has_inst("Expect");
7870         if ($can_expect) {
7871             $want_expect = 1;
7872         } else {
7873             $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
7874                                     "testing without\n");
7875         }
7876     }
7877     my $test_report = CPAN::HandleConfig->prefs_lookup($self,
7878                                                        q{test_report});
7879     my $want_report;
7880     if ($test_report) {
7881         my $can_report = $CPAN::META->has_inst("CPAN::Reporter");
7882         if ($can_report) {
7883             $want_report = 1;
7884         } else {
7885             $CPAN::Frontend->mywarn("CPAN::Reporter not installed, falling back to ".
7886                                     "testing without\n");
7887         }
7888     }
7889     my $ready_to_report = $want_report;
7890     if ($ready_to_report
7891         && (
7892             substr($self->id,-1,1) eq "."
7893             ||
7894             $self->author->id eq "LOCAL"
7895            )
7896        ) {
7897         $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
7898                                 "for local directories\n");
7899         $ready_to_report = 0;
7900     }
7901     if ($ready_to_report
7902         &&
7903         $self->prefs->{patches}
7904         &&
7905         @{$self->prefs->{patches}}
7906         &&
7907         $self->{patched}
7908        ) {
7909         $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
7910                                 "when the source has been patched\n");
7911         $ready_to_report = 0;
7912     }
7913     if ($want_expect) {
7914         if ($ready_to_report) {
7915             $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ".
7916                                     "not supported when distroprefs specify ".
7917                                     "an interactive test\n");
7918         }
7919         $tests_ok = $self->_run_via_expect($system,$expect_model) == 0;
7920     } elsif ( $ready_to_report ) {
7921         $tests_ok = CPAN::Reporter::test($self, $system);
7922     } else {
7923         $tests_ok = system($system) == 0;
7924     }
7925     $self->introduce_myself;
7926     if ( $tests_ok ) {
7927         {
7928             my @prereq;
7929
7930             # local $CPAN::DEBUG = 16; # Distribution
7931             for my $m (keys %{$self->{sponsored_mods}}) {
7932                 my $m_obj = CPAN::Shell->expand("Module",$m) or next;
7933                 # XXX we need available_version which reflects
7934                 # $ENV{PERL5LIB} so that already tested but not yet
7935                 # installed modules are counted.
7936                 my $available_version = $m_obj->available_version;
7937                 my $available_file = $m_obj->available_file;
7938                 if ($available_version &&
7939                     !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m})
7940                    ) {
7941                     CPAN->debug("m[$m] good enough available_version[$available_version]")
7942                         if $CPAN::DEBUG;
7943                 } elsif ($available_file
7944                          && (
7945                              !$self->{prereq_pm}{$m}
7946                              ||
7947                              $self->{prereq_pm}{$m} == 0
7948                             )
7949                         ) {
7950                     # lex Class::Accessor::Chained::Fast which has no $VERSION
7951                     CPAN->debug("m[$m] have available_file[$available_file]")
7952                         if $CPAN::DEBUG;
7953                 } else {
7954                     push @prereq, $m;
7955                 }
7956             }
7957             if (@prereq){
7958                 my $cnt = @prereq;
7959                 my $which = join ",", @prereq;
7960                 my $but = $cnt == 1 ? "one dependency not OK ($which)" :
7961                     "$cnt dependencies missing ($which)";
7962                 $CPAN::Frontend->mywarn("Tests succeeded but $but\n");
7963                 $self->{make_test} = CPAN::Distrostatus->new("NO $but");
7964                 $self->store_persistent_state;
7965                 return;
7966             }
7967         }
7968
7969         $CPAN::Frontend->myprint("  $system -- OK\n");
7970         $self->{make_test} = CPAN::Distrostatus->new("YES");
7971         $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
7972         # probably impossible to need the next line because badtestcnt
7973         # has a lifespan of one command
7974         delete $self->{badtestcnt};
7975     } else {
7976         $self->{make_test} = CPAN::Distrostatus->new("NO");
7977         $self->{badtestcnt}++;
7978         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
7979     }
7980     $self->store_persistent_state;
7981 }
7982
7983 sub _prefs_with_expect {
7984     my($self,$where) = @_;
7985     return unless my $prefs = $self->prefs;
7986     return unless my $where_prefs = $prefs->{$where};
7987     if ($where_prefs->{expect}) {
7988         return {
7989                 mode => "deterministic",
7990                 timeout => 15,
7991                 talk => $where_prefs->{expect},
7992                };
7993     } elsif ($where_prefs->{"eexpect"}) {
7994         return $where_prefs->{"eexpect"};
7995     }
7996     return;
7997 }
7998
7999 #-> sub CPAN::Distribution::clean ;
8000 sub clean {
8001     my($self) = @_;
8002     my $make = $self->{modulebuild} ? "Build" : "make";
8003     $CPAN::Frontend->myprint("Running $make clean\n");
8004     unless (exists $self->{archived}) {
8005         $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped".
8006                                 "/untarred, nothing done\n");
8007         return 1;
8008     }
8009     unless (exists $self->{build_dir}) {
8010         $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
8011         return 1;
8012     }
8013   EXCUSE: {
8014         my @e;
8015         exists $self->{make_clean} and $self->{make_clean} eq "YES" and
8016             push @e, "make clean already called once";
8017         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
8018     }
8019     chdir $self->{build_dir} or
8020         Carp::confess("Couldn't chdir to $self->{build_dir}: $!");
8021     $self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG;
8022
8023     if ($^O eq 'MacOS') {
8024         Mac::BuildTools::make_clean($self);
8025         return;
8026     }
8027
8028     my $system;
8029     if ($self->{modulebuild}) {
8030         unless (-f "Build") {
8031             my $cwd = CPAN::anycwd();
8032             $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
8033                                     " in cwd[$cwd]. Danger, Will Robinson!");
8034             $CPAN::Frontend->mysleep(5);
8035         }
8036         $system = sprintf "%s clean", $self->_build_command();
8037     } else {
8038         $system  = join " ", $self->_make_command(), "clean";
8039     }
8040     my $system_ok = system($system) == 0;
8041     $self->introduce_myself;
8042     if ( $system_ok ) {
8043       $CPAN::Frontend->myprint("  $system -- OK\n");
8044
8045       # $self->force;
8046
8047       # Jost Krieger pointed out that this "force" was wrong because
8048       # it has the effect that the next "install" on this distribution
8049       # will untar everything again. Instead we should bring the
8050       # object's state back to where it is after untarring.
8051
8052       for my $k (qw(
8053                     force_update
8054                     install
8055                     writemakefile
8056                     make
8057                     make_test
8058                    )) {
8059           delete $self->{$k};
8060       }
8061       $self->{make_clean} = CPAN::Distrostatus->new("YES");
8062
8063     } else {
8064       # Hmmm, what to do if make clean failed?
8065
8066       $self->{make_clean} = CPAN::Distrostatus->new("NO");
8067       $CPAN::Frontend->mywarn(qq{  $system -- NOT OK\n});
8068
8069       # 2006-02-27: seems silly to me to force a make now
8070       # $self->force("make"); # so that this directory won't be used again
8071
8072     }
8073     $self->store_persistent_state;
8074 }
8075
8076 #-> sub CPAN::Distribution::goto ;
8077 sub goto {
8078     my($self,$goto) = @_;
8079     $goto = $self->normalize($goto);
8080
8081     # inject into the queue
8082
8083     CPAN::Queue->delete($self->id);
8084     CPAN::Queue->jumpqueue([$goto,$self->{reqtype}]);
8085
8086     # and run where we left off
8087
8088     my($method) = (caller(1))[3];
8089     CPAN->instance("CPAN::Distribution",$goto)->$method;
8090     CPAN::Queue->delete_first($goto);
8091 }
8092
8093 #-> sub CPAN::Distribution::install ;
8094 sub install {
8095     my($self) = @_;
8096     if (my $goto = $self->prefs->{goto}) {
8097         return $self->goto($goto);
8098     }
8099     $DB::single=1;
8100     unless ($self->{badtestcnt}) {
8101         $self->test;
8102     }
8103     if ($CPAN::Signal){
8104       delete $self->{force_update};
8105       return;
8106     }
8107     my $make = $self->{modulebuild} ? "Build" : "make";
8108     $CPAN::Frontend->myprint("Running $make install\n");
8109   EXCUSE: {
8110         my @e;
8111         unless (exists $self->{make} or exists $self->{later}) {
8112             push @e,
8113                 "Make had some problems, won't install";
8114         }
8115
8116         exists $self->{make} and
8117             (
8118              UNIVERSAL::can($self->{make},"failed") ?
8119              $self->{make}->failed :
8120              $self->{make} =~ /^NO/
8121             ) and
8122                 push @e, "Make had returned bad status, install seems impossible";
8123
8124         if (exists $self->{build_dir}) {
8125         } elsif (!@e) {
8126             push @e, "Has no own directory";
8127         }
8128
8129         if (exists $self->{make_test} and
8130             (
8131              UNIVERSAL::can($self->{make_test},"failed") ?
8132              $self->{make_test}->failed :
8133              $self->{make_test} =~ /^NO/
8134             )){
8135             if ($self->{force_update}) {
8136                 $self->{make_test}->text("FAILED but failure ignored because ".
8137                                          "'force' in effect");
8138             } else {
8139                 push @e, "make test had returned bad status, ".
8140                     "won't install without force"
8141             }
8142         }
8143         if (exists $self->{install}) {
8144             if (UNIVERSAL::can($self->{install},"text") ?
8145                 $self->{install}->text eq "YES" :
8146                 $self->{install} =~ /^YES/
8147                ) {
8148                 push @e, "Already done";
8149             } else {
8150                 # comment in Todo on 2006-02-11; maybe retry?
8151                 push @e, "Already tried without success";
8152             }
8153         }
8154
8155         exists $self->{later} and length($self->{later}) and
8156             push @e, $self->{later};
8157
8158         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
8159         unless (chdir $self->{build_dir}) {
8160             push @e, "Couldn't chdir to '$self->{build_dir}': $!";
8161         }
8162         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
8163     }
8164     $self->debug("Changed directory to $self->{build_dir}")
8165         if $CPAN::DEBUG;
8166
8167     if ($^O eq 'MacOS') {
8168         Mac::BuildTools::make_install($self);
8169         return;
8170     }
8171
8172     my $system;
8173     if (my $commandline = $self->prefs->{install}{commandline}) {
8174         $system = $commandline;
8175         $ENV{PERL} = $^X;
8176     } elsif ($self->{modulebuild}) {
8177         my($mbuild_install_build_command) =
8178             exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
8179                 $CPAN::Config->{mbuild_install_build_command} ?
8180                     $CPAN::Config->{mbuild_install_build_command} :
8181                         $self->_build_command();
8182         $system = sprintf("%s install %s",
8183                           $mbuild_install_build_command,
8184                           $CPAN::Config->{mbuild_install_arg},
8185                          );
8186     } else {
8187         my($make_install_make_command) =
8188             CPAN::HandleConfig->prefs_lookup($self,
8189                                              q{make_install_make_command})
8190                   || $self->_make_command();
8191         $system = sprintf("%s install %s",
8192                           $make_install_make_command,
8193                           $CPAN::Config->{make_install_arg},
8194                          );
8195     }
8196
8197     my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 ";
8198     my $brip = CPAN::HandleConfig->prefs_lookup($self,
8199                                                 q{build_requires_install_policy});
8200     $brip ||="ask/yes";
8201     my $id = $self->id;
8202     my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command
8203     my $want_install = "yes";
8204     if ($reqtype eq "b") {
8205         if ($brip eq "no") {
8206             $want_install = "no";
8207         } elsif ($brip =~ m|^ask/(.+)|) {
8208             my $default = $1;
8209             $default = "yes" unless $default =~ /^(y|n)/i;
8210             $want_install =
8211                 CPAN::Shell::colorable_makemaker_prompt
8212                       ("$id is just needed temporarily during building or testing. ".
8213                        "Do you want to install it permanently? (Y/n)",
8214                        $default);
8215         }
8216     }
8217     unless ($want_install =~ /^y/i) {
8218         my $is_only = "is only 'build_requires'";
8219         $CPAN::Frontend->mywarn("Not installing because $is_only\n");
8220         $self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
8221         delete $self->{force_update};
8222         return;
8223     }
8224     my($pipe) = FileHandle->new("$system $stderr |");
8225     my($makeout) = "";
8226     while (<$pipe>){
8227         print $_; # intentionally NOT use Frontend->myprint because it
8228                   # looks irritating when we markup in color what we
8229                   # just pass through from an external program
8230         $makeout .= $_;
8231     }
8232     $pipe->close;
8233     my $close_ok = $? == 0;
8234     $self->introduce_myself;
8235     if ( $close_ok ) {
8236         $CPAN::Frontend->myprint("  $system -- OK\n");
8237         $CPAN::META->is_installed($self->{build_dir});
8238         $self->{install} = CPAN::Distrostatus->new("YES");
8239     } else {
8240         $self->{install} = CPAN::Distrostatus->new("NO");
8241         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
8242         my $mimc =
8243             CPAN::HandleConfig->prefs_lookup($self,
8244                                              q{make_install_make_command});
8245         if (
8246             $makeout =~ /permission/s
8247             && $> > 0
8248             && (
8249                 ! $mimc
8250                 || $mimc eq (CPAN::HandleConfig->prefs_lookup($self,
8251                                                               q{make}))
8252                )
8253            ) {
8254             $CPAN::Frontend->myprint(
8255                                      qq{----\n}.
8256                                      qq{  You may have to su }.
8257                                      qq{to root to install the package\n}.
8258                                      qq{  (Or you may want to run something like\n}.
8259                                      qq{    o conf make_install_make_command 'sudo make'\n}.
8260                                      qq{  to raise your permissions.}
8261                                     );
8262         }
8263     }
8264     delete $self->{force_update};
8265     # $DB::single = 1;
8266     $self->store_persistent_state;
8267 }
8268
8269 sub introduce_myself {
8270     my($self) = @_;
8271     $CPAN::Frontend->myprint(sprintf("  %s\n",$self->pretty_id));
8272 }
8273
8274 #-> sub CPAN::Distribution::dir ;
8275 sub dir {
8276     shift->{build_dir};
8277 }
8278
8279 #-> sub CPAN::Distribution::perldoc ;
8280 sub perldoc {
8281     my($self) = @_;
8282
8283     my($dist) = $self->id;
8284     my $package = $self->called_for;
8285
8286     $self->_display_url( $CPAN::Defaultdocs . $package );
8287 }
8288
8289 #-> sub CPAN::Distribution::_check_binary ;
8290 sub _check_binary {
8291     my ($dist,$shell,$binary) = @_;
8292     my ($pid,$out);
8293
8294     $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
8295       if $CPAN::DEBUG;
8296
8297     if ($CPAN::META->has_inst("File::Which")) {
8298         return File::Which::which($binary);
8299     } else {
8300         local *README;
8301         $pid = open README, "which $binary|"
8302             or $CPAN::Frontend->mywarn(qq{Could not fork 'which $binary': $!\n});
8303         return unless $pid;
8304         while (<README>) {
8305             $out .= $_;
8306         }
8307         close README
8308             or $CPAN::Frontend->mywarn("Could not run 'which $binary': $!\n")
8309                 and return;
8310     }
8311
8312     $CPAN::Frontend->myprint(qq{   + $out \n})
8313       if $CPAN::DEBUG && $out;
8314
8315     return $out;
8316 }
8317
8318 #-> sub CPAN::Distribution::_display_url ;
8319 sub _display_url {
8320     my($self,$url) = @_;
8321     my($res,$saved_file,$pid,$out);
8322
8323     $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
8324       if $CPAN::DEBUG;
8325
8326     # should we define it in the config instead?
8327     my $html_converter = "html2text";
8328
8329     my $web_browser = $CPAN::Config->{'lynx'} || undef;
8330     my $web_browser_out = $web_browser
8331       ? CPAN::Distribution->_check_binary($self,$web_browser)
8332         : undef;
8333
8334     if ($web_browser_out) {
8335         # web browser found, run the action
8336         my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
8337         $CPAN::Frontend->myprint(qq{system[$browser $url]})
8338           if $CPAN::DEBUG;
8339         $CPAN::Frontend->myprint(qq{
8340 Displaying URL
8341   $url
8342 with browser $browser
8343 });
8344         $CPAN::Frontend->mysleep(1);
8345         system("$browser $url");
8346         if ($saved_file) { 1 while unlink($saved_file) }
8347     } else {
8348         # web browser not found, let's try text only
8349         my $html_converter_out =
8350           CPAN::Distribution->_check_binary($self,$html_converter);
8351         $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out);
8352
8353         if ($html_converter_out ) {
8354             # html2text found, run it
8355             $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
8356             $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n})
8357                 unless defined($saved_file);
8358
8359             local *README;
8360             $pid = open README, "$html_converter $saved_file |"
8361               or $CPAN::Frontend->mydie(qq{
8362 Could not fork '$html_converter $saved_file': $!});
8363             my($fh,$filename);
8364             if ($CPAN::META->has_inst("File::Temp")) {
8365                 $fh = File::Temp->new(
8366                                       template => 'cpan_htmlconvert_XXXX',
8367                                       suffix => '.txt',
8368                                       unlink => 0,
8369                                      );
8370                 $filename = $fh->filename;
8371             } else {
8372                 $filename = "cpan_htmlconvert_$$.txt";
8373                 $fh = FileHandle->new();
8374                 open $fh, ">$filename" or die;
8375             }
8376             while (<README>) {
8377                 $fh->print($_);
8378             }
8379             close README or
8380                 $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
8381             my $tmpin = $fh->filename;
8382             $CPAN::Frontend->myprint(sprintf(qq{
8383 Run '%s %s' and
8384 saved output to %s\n},
8385                                              $html_converter,
8386                                              $saved_file,
8387                                              $tmpin,
8388                                             )) if $CPAN::DEBUG;
8389             close $fh;
8390             local *FH;
8391             open FH, $tmpin
8392                 or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
8393             my $fh_pager = FileHandle->new;
8394             local($SIG{PIPE}) = "IGNORE";
8395             my $pager = $CPAN::Config->{'pager'} || "cat";
8396             $fh_pager->open("|$pager")
8397                 or $CPAN::Frontend->mydie(qq{
8398 Could not open pager '$pager': $!});
8399             $CPAN::Frontend->myprint(qq{
8400 Displaying URL
8401   $url
8402 with pager "$pager"
8403 });
8404             $CPAN::Frontend->mysleep(1);
8405             $fh_pager->print(<FH>);
8406             $fh_pager->close;
8407         } else {
8408             # coldn't find the web browser or html converter
8409             $CPAN::Frontend->myprint(qq{
8410 You need to install lynx or $html_converter to use this feature.});
8411         }
8412     }
8413 }
8414
8415 #-> sub CPAN::Distribution::_getsave_url ;
8416 sub _getsave_url {
8417     my($dist, $shell, $url) = @_;
8418
8419     $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
8420       if $CPAN::DEBUG;
8421
8422     my($fh,$filename);
8423     if ($CPAN::META->has_inst("File::Temp")) {
8424         $fh = File::Temp->new(
8425                               template => "cpan_getsave_url_XXXX",
8426                               suffix => ".html",
8427                               unlink => 0,
8428                              );
8429         $filename = $fh->filename;
8430     } else {
8431         $fh = FileHandle->new;
8432         $filename = "cpan_getsave_url_$$.html";
8433     }
8434     my $tmpin = $filename;
8435     if ($CPAN::META->has_usable('LWP')) {
8436         $CPAN::Frontend->myprint("Fetching with LWP:
8437   $url
8438 ");
8439         my $Ua;
8440         CPAN::LWP::UserAgent->config;
8441         eval { $Ua = CPAN::LWP::UserAgent->new; };
8442         if ($@) {
8443             $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
8444             return;
8445         } else {
8446             my($var);
8447             $Ua->proxy('http', $var)
8448                 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
8449             $Ua->no_proxy($var)
8450                 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
8451         }
8452
8453         my $req = HTTP::Request->new(GET => $url);
8454         $req->header('Accept' => 'text/html');
8455         my $res = $Ua->request($req);
8456         if ($res->is_success) {
8457             $CPAN::Frontend->myprint(" + request successful.\n")
8458                 if $CPAN::DEBUG;
8459             print $fh $res->content;
8460             close $fh;
8461             $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
8462                 if $CPAN::DEBUG;
8463             return $tmpin;
8464         } else {
8465             $CPAN::Frontend->myprint(sprintf(
8466                                              "LWP failed with code[%s], message[%s]\n",
8467                                              $res->code,
8468                                              $res->message,
8469                                             ));
8470             return;
8471         }
8472     } else {
8473         $CPAN::Frontend->mywarn("  LWP not available\n");
8474         return;
8475     }
8476 }
8477
8478 # sub CPAN::Distribution::_build_command
8479 sub _build_command {
8480     my($self) = @_;
8481     if ($^O eq "MSWin32") { # special code needed at least up to
8482                             # Module::Build 0.2611 and 0.2706; a fix
8483                             # in M:B has been promised 2006-01-30
8484         my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
8485         return "$perl ./Build";
8486     }
8487     return "./Build";
8488 }
8489
8490 package CPAN::Bundle;
8491 use strict;
8492
8493 sub look {
8494     my $self = shift;
8495     $CPAN::Frontend->myprint($self->as_string);
8496 }
8497
8498 sub undelay {
8499     my $self = shift;
8500     delete $self->{later};
8501     for my $c ( $self->contains ) {
8502         my $obj = CPAN::Shell->expandany($c) or next;
8503         $obj->undelay;
8504     }
8505 }
8506
8507 # mark as dirty/clean
8508 #-> sub CPAN::Bundle::color_cmd_tmps ;
8509 sub color_cmd_tmps {
8510     my($self) = shift;
8511     my($depth) = shift || 0;
8512     my($color) = shift || 0;
8513     my($ancestors) = shift || [];
8514     # a module needs to recurse to its cpan_file, a distribution needs
8515     # to recurse into its prereq_pms, a bundle needs to recurse into its modules
8516
8517     return if exists $self->{incommandcolor}
8518         && $color==1
8519         && $self->{incommandcolor}==$color;
8520     if ($depth>=$CPAN::MAX_RECURSION){
8521         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
8522     }
8523     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
8524
8525     for my $c ( $self->contains ) {
8526         my $obj = CPAN::Shell->expandany($c) or next;
8527         CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
8528         $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
8529     }
8530     # never reached code?
8531     #if ($color==0) {
8532       #delete $self->{badtestcnt};
8533     #}
8534     $self->{incommandcolor} = $color;
8535 }
8536
8537 #-> sub CPAN::Bundle::as_string ;
8538 sub as_string {
8539     my($self) = @_;
8540     $self->contains;
8541     # following line must be "=", not "||=" because we have a moving target
8542     $self->{INST_VERSION} = $self->inst_version;
8543     return $self->SUPER::as_string;
8544 }
8545
8546 #-> sub CPAN::Bundle::contains ;
8547 sub contains {
8548     my($self) = @_;
8549     my($inst_file) = $self->inst_file || "";
8550     my($id) = $self->id;
8551     $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
8552     if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) {
8553         undef $inst_file;
8554     }
8555     unless ($inst_file) {
8556         # Try to get at it in the cpan directory
8557         $self->debug("no inst_file") if $CPAN::DEBUG;
8558         my $cpan_file;
8559         $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
8560               $cpan_file = $self->cpan_file;
8561         if ($cpan_file eq "N/A") {
8562             $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
8563   Maybe stale symlink? Maybe removed during session? Giving up.\n");
8564         }
8565         my $dist = $CPAN::META->instance('CPAN::Distribution',
8566                                          $self->cpan_file);
8567         $self->debug("before get id[$dist->{ID}]") if $CPAN::DEBUG;
8568         $dist->get;
8569         $self->debug("after get id[$dist->{ID}]") if $CPAN::DEBUG;
8570         my($todir) = $CPAN::Config->{'cpan_home'};
8571         my(@me,$from,$to,$me);
8572         @me = split /::/, $self->id;
8573         $me[-1] .= ".pm";
8574         $me = File::Spec->catfile(@me);
8575         $from = $self->find_bundle_file($dist->{build_dir},join('/',@me));
8576         $to = File::Spec->catfile($todir,$me);
8577         File::Path::mkpath(File::Basename::dirname($to));
8578         File::Copy::copy($from, $to)
8579               or Carp::confess("Couldn't copy $from to $to: $!");
8580         $inst_file = $to;
8581     }
8582     my @result;
8583     my $fh = FileHandle->new;
8584     local $/ = "\n";
8585     open($fh,$inst_file) or die "Could not open '$inst_file': $!";
8586     my $in_cont = 0;
8587     $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
8588     while (<$fh>) {
8589         $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
8590             m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
8591         next unless $in_cont;
8592         next if /^=/;
8593         s/\#.*//;
8594         next if /^\s+$/;
8595         chomp;
8596         push @result, (split " ", $_, 2)[0];
8597     }
8598     close $fh;
8599     delete $self->{STATUS};
8600     $self->{CONTAINS} = \@result;
8601     $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
8602     unless (@result) {
8603         $CPAN::Frontend->mywarn(qq{
8604 The bundle file "$inst_file" may be a broken
8605 bundlefile. It seems not to contain any bundle definition.
8606 Please check the file and if it is bogus, please delete it.
8607 Sorry for the inconvenience.
8608 });
8609     }
8610     @result;
8611 }
8612
8613 #-> sub CPAN::Bundle::find_bundle_file
8614 # $where is in local format, $what is in unix format
8615 sub find_bundle_file {
8616     my($self,$where,$what) = @_;
8617     $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
8618 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
8619 ###    my $bu = File::Spec->catfile($where,$what);
8620 ###    return $bu if -f $bu;
8621     my $manifest = File::Spec->catfile($where,"MANIFEST");
8622     unless (-f $manifest) {
8623         require ExtUtils::Manifest;
8624         my $cwd = CPAN::anycwd();
8625         $self->safe_chdir($where);
8626         ExtUtils::Manifest::mkmanifest();
8627         $self->safe_chdir($cwd);
8628     }
8629     my $fh = FileHandle->new($manifest)
8630         or Carp::croak("Couldn't open $manifest: $!");
8631     local($/) = "\n";
8632     my $bundle_filename = $what;
8633     $bundle_filename =~ s|Bundle.*/||;
8634     my $bundle_unixpath;
8635     while (<$fh>) {
8636         next if /^\s*\#/;
8637         my($file) = /(\S+)/;
8638         if ($file =~ m|\Q$what\E$|) {
8639             $bundle_unixpath = $file;
8640             # return File::Spec->catfile($where,$bundle_unixpath); # bad
8641             last;
8642         }
8643         # retry if she managed to have no Bundle directory
8644         $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
8645     }
8646     return File::Spec->catfile($where, split /\//, $bundle_unixpath)
8647         if $bundle_unixpath;
8648     Carp::croak("Couldn't find a Bundle file in $where");
8649 }
8650
8651 # needs to work quite differently from Module::inst_file because of
8652 # cpan_home/Bundle/ directory and the possibility that we have
8653 # shadowing effect. As it makes no sense to take the first in @INC for
8654 # Bundles, we parse them all for $VERSION and take the newest.
8655
8656 #-> sub CPAN::Bundle::inst_file ;
8657 sub inst_file {
8658     my($self) = @_;
8659     my($inst_file);
8660     my(@me);
8661     @me = split /::/, $self->id;
8662     $me[-1] .= ".pm";
8663     my($incdir,$bestv);
8664     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
8665         my $bfile = File::Spec->catfile($incdir, @me);
8666         CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
8667         next unless -f $bfile;
8668         my $foundv = MM->parse_version($bfile);
8669         if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
8670             $self->{INST_FILE} = $bfile;
8671             $self->{INST_VERSION} = $bestv = $foundv;
8672         }
8673     }
8674     $self->{INST_FILE};
8675 }
8676
8677 #-> sub CPAN::Bundle::inst_version ;
8678 sub inst_version {
8679     my($self) = @_;
8680     $self->inst_file; # finds INST_VERSION as side effect
8681     $self->{INST_VERSION};
8682 }
8683
8684 #-> sub CPAN::Bundle::rematein ;
8685 sub rematein {
8686     my($self,$meth) = @_;
8687     $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
8688     my($id) = $self->id;
8689     Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
8690         unless $self->inst_file || $self->cpan_file;
8691     my($s,%fail);
8692     for $s ($self->contains) {
8693         my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
8694             $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
8695         if ($type eq 'CPAN::Distribution') {
8696             $CPAN::Frontend->mywarn(qq{
8697 The Bundle }.$self->id.qq{ contains
8698 explicitly a file '$s'.
8699 Going to $meth that.
8700 });
8701             $CPAN::Frontend->mysleep(5);
8702         }
8703         # possibly noisy action:
8704         $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
8705         my $obj = $CPAN::META->instance($type,$s);
8706         $obj->{reqtype} = $self->{reqtype};
8707         $obj->$meth();
8708     }
8709 }
8710
8711 # If a bundle contains another that contains an xs_file we have here,
8712 # we just don't bother I suppose
8713 #-> sub CPAN::Bundle::xs_file
8714 sub xs_file {
8715     return 0;
8716 }
8717
8718 #-> sub CPAN::Bundle::force ;
8719 sub fforce   { shift->rematein('fforce',@_); }
8720 #-> sub CPAN::Bundle::force ;
8721 sub force   { shift->rematein('force',@_); }
8722 #-> sub CPAN::Bundle::notest ;
8723 sub notest  { shift->rematein('notest',@_); }
8724 #-> sub CPAN::Bundle::get ;
8725 sub get     { shift->rematein('get',@_); }
8726 #-> sub CPAN::Bundle::make ;
8727 sub make    { shift->rematein('make',@_); }
8728 #-> sub CPAN::Bundle::test ;
8729 sub test    {
8730     my $self = shift;
8731     # $self->{badtestcnt} ||= 0;
8732     $self->rematein('test',@_);
8733 }
8734 #-> sub CPAN::Bundle::install ;
8735 sub install {
8736   my $self = shift;
8737   $self->rematein('install',@_);
8738 }
8739 #-> sub CPAN::Bundle::clean ;
8740 sub clean   { shift->rematein('clean',@_); }
8741
8742 #-> sub CPAN::Bundle::uptodate ;
8743 sub uptodate {
8744     my($self) = @_;
8745     return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
8746     my $c;
8747     foreach $c ($self->contains) {
8748         my $obj = CPAN::Shell->expandany($c);
8749         return 0 unless $obj->uptodate;
8750     }
8751     return 1;
8752 }
8753
8754 #-> sub CPAN::Bundle::readme ;
8755 sub readme  {
8756     my($self) = @_;
8757     my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
8758 No File found for bundle } . $self->id . qq{\n}), return;
8759     $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
8760     $CPAN::META->instance('CPAN::Distribution',$file)->readme;
8761 }
8762
8763 package CPAN::Module;
8764 use strict;
8765
8766 # Accessors
8767 # sub CPAN::Module::userid
8768 sub userid {
8769     my $self = shift;
8770     my $ro = $self->ro;
8771     return unless $ro;
8772     return $ro->{userid} || $ro->{CPAN_USERID};
8773 }
8774 # sub CPAN::Module::description
8775 sub description {
8776     my $self = shift;
8777     my $ro = $self->ro or return "";
8778     $ro->{description}
8779 }
8780
8781 sub distribution {
8782     my($self) = @_;
8783     CPAN::Shell->expand("Distribution",$self->cpan_file);
8784 }
8785
8786 # sub CPAN::Module::undelay
8787 sub undelay {
8788     my $self = shift;
8789     delete $self->{later};
8790     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
8791         $dist->undelay;
8792     }
8793 }
8794
8795 # mark as dirty/clean
8796 #-> sub CPAN::Module::color_cmd_tmps ;
8797 sub color_cmd_tmps {
8798     my($self) = shift;
8799     my($depth) = shift || 0;
8800     my($color) = shift || 0;
8801     my($ancestors) = shift || [];
8802     # a module needs to recurse to its cpan_file
8803
8804     return if exists $self->{incommandcolor}
8805         && $color==1
8806         && $self->{incommandcolor}==$color;
8807     return if $color==0 && !$self->{incommandcolor};
8808     if ($color>=1) {
8809         if ( $self->uptodate ) {
8810             $self->{incommandcolor} = $color;
8811             return;
8812         } elsif (my $have_version = $self->available_version) {
8813             # maybe what we have is good enough
8814             if (@$ancestors) {
8815                 my $who_asked_for_me = $ancestors->[-1];
8816                 my $obj = CPAN::Shell->expandany($who_asked_for_me);
8817                 if (0) {
8818                 } elsif ($obj->isa("CPAN::Bundle")) {
8819                     # bundles cannot specify a minimum version
8820                     return;
8821                 } elsif ($obj->isa("CPAN::Distribution")) {
8822                     if (my $prereq_pm = $obj->prereq_pm) {
8823                         for my $k (keys %$prereq_pm) {
8824                             if (my $want_version = $prereq_pm->{$k}{$self->id}) {
8825                                 if (CPAN::Version->vcmp($have_version,$want_version) >= 0) {
8826                                     $self->{incommandcolor} = $color;
8827                                     return;
8828                                 }
8829                             }
8830                         }
8831                     }
8832                 }
8833             }
8834         }
8835     } else {
8836         $self->{incommandcolor} = $color; # set me before recursion,
8837                                           # so we can break it
8838     }
8839     if ($depth>=$CPAN::MAX_RECURSION){
8840         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
8841     }
8842     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
8843
8844     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
8845         $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
8846     }
8847     # unreached code?
8848     # if ($color==0) {
8849     #    delete $self->{badtestcnt};
8850     # }
8851     $self->{incommandcolor} = $color;
8852 }
8853
8854 #-> sub CPAN::Module::as_glimpse ;
8855 sub as_glimpse {
8856     my($self) = @_;
8857     my(@m);
8858     my $class = ref($self);
8859     $class =~ s/^CPAN:://;
8860     my $color_on = "";
8861     my $color_off = "";
8862     if (
8863         $CPAN::Shell::COLOR_REGISTERED
8864         &&
8865         $CPAN::META->has_inst("Term::ANSIColor")
8866         &&
8867         $self->description
8868        ) {
8869         $color_on = Term::ANSIColor::color("green");
8870         $color_off = Term::ANSIColor::color("reset");
8871     }
8872     my $uptodateness = " ";
8873     if ($class eq "Bundle") {
8874     } elsif ($self->uptodate) {
8875         $uptodateness = "=";
8876     } elsif ($self->inst_version) {
8877         $uptodateness = "<";
8878     }
8879     push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n",
8880                      $class,
8881                      $uptodateness,
8882                      $color_on,
8883                      $self->id,
8884                      $color_off,
8885                      ($self->distribution ?
8886                       $self->distribution->pretty_id :
8887                       $self->cpan_userid
8888                      ),
8889                     );
8890     join "", @m;
8891 }
8892
8893 #-> sub CPAN::Module::dslip_status
8894 sub dslip_status {
8895     my($self) = @_;
8896     my($stat);
8897     # development status
8898     @{$stat->{D}}{qw,i c a b R M S,}     = qw,idea
8899                                               pre-alpha alpha beta released
8900                                               mature standard,;
8901     # support level
8902     @{$stat->{S}}{qw,m d u n a,}         = qw,mailing-list
8903                                               developer comp.lang.perl.*
8904                                               none abandoned,;
8905     # language
8906     @{$stat->{L}}{qw,p c + o h,}         = qw,perl C C++ other hybrid,;
8907     # interface
8908     @{$stat->{I}}{qw,f r O p h n,}       = qw,functions
8909                                               references+ties
8910                                               object-oriented pragma
8911                                               hybrid none,;
8912     # public licence
8913     @{$stat->{P}}{qw,p g l b a o d r n,} = qw,Standard-Perl
8914                                               GPL LGPL
8915                                               BSD Artistic
8916                                               open-source
8917                                               distribution_allowed
8918                                               restricted_distribution
8919                                               no_licence,;
8920     for my $x (qw(d s l i p)) {
8921         $stat->{$x}{' '} = 'unknown';
8922         $stat->{$x}{'?'} = 'unknown';
8923     }
8924     my $ro = $self->ro;
8925     return +{} unless $ro && $ro->{statd};
8926     return {
8927             D  => $ro->{statd},
8928             S  => $ro->{stats},
8929             L  => $ro->{statl},
8930             I  => $ro->{stati},
8931             P  => $ro->{statp},
8932             DV => $stat->{D}{$ro->{statd}},
8933             SV => $stat->{S}{$ro->{stats}},
8934             LV => $stat->{L}{$ro->{statl}},
8935             IV => $stat->{I}{$ro->{stati}},
8936             PV => $stat->{P}{$ro->{statp}},
8937            };
8938 }
8939
8940 #-> sub CPAN::Module::as_string ;
8941 sub as_string {
8942     my($self) = @_;
8943     my(@m);
8944     CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
8945     my $class = ref($self);
8946     $class =~ s/^CPAN:://;
8947     local($^W) = 0;
8948     push @m, $class, " id = $self->{ID}\n";
8949     my $sprintf = "    %-12s %s\n";
8950     push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
8951         if $self->description;
8952     my $sprintf2 = "    %-12s %s (%s)\n";
8953     my($userid);
8954     $userid = $self->userid;
8955     if ( $userid ){
8956         my $author;
8957         if ($author = CPAN::Shell->expand('Author',$userid)) {
8958           my $email = "";
8959           my $m; # old perls
8960           if ($m = $author->email) {
8961             $email = " <$m>";
8962           }
8963           push @m, sprintf(
8964                            $sprintf2,
8965                            'CPAN_USERID',
8966                            $userid,
8967                            $author->fullname . $email
8968                           );
8969         }
8970     }
8971     push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
8972         if $self->cpan_version;
8973     if (my $cpan_file = $self->cpan_file){
8974         push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
8975         if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
8976             my $upload_date = $dist->upload_date;
8977             if ($upload_date) {
8978                 push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
8979             }
8980         }
8981     }
8982     my $sprintf3 = "    %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n";
8983     my $dslip = $self->dslip_status;
8984     push @m, sprintf(
8985                      $sprintf3,
8986                      'DSLIP_STATUS',
8987                      @{$dslip}{qw(D S L I P DV SV LV IV PV)},
8988                     ) if $dslip->{D};
8989     my $local_file = $self->inst_file;
8990     unless ($self->{MANPAGE}) {
8991         my $manpage;
8992         if ($local_file) {
8993             $manpage = $self->manpage_headline($local_file);
8994         } else {
8995             # If we have already untarred it, we should look there
8996             my $dist = $CPAN::META->instance('CPAN::Distribution',
8997                                              $self->cpan_file);
8998             # warn "dist[$dist]";
8999             # mff=manifest file; mfh=manifest handle
9000             my($mff,$mfh);
9001             if (
9002                 $dist->{build_dir}
9003                 and
9004                 (-f  ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
9005                 and
9006                 $mfh = FileHandle->new($mff)
9007                ) {
9008                 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
9009                 my $lfre = $self->id; # local file RE
9010                 $lfre =~ s/::/./g;
9011                 $lfre .= "\\.pm\$";
9012                 my($lfl); # local file file
9013                 local $/ = "\n";
9014                 my(@mflines) = <$mfh>;
9015                 for (@mflines) {
9016                     s/^\s+//;
9017                     s/\s.*//s;
9018                 }
9019                 while (length($lfre)>5 and !$lfl) {
9020                     ($lfl) = grep /$lfre/, @mflines;
9021                     CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
9022                     $lfre =~ s/.+?\.//;
9023                 }
9024                 $lfl =~ s/\s.*//; # remove comments
9025                 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
9026                 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
9027                 # warn "lfl_abs[$lfl_abs]";
9028                 if (-f $lfl_abs) {
9029                     $manpage = $self->manpage_headline($lfl_abs);
9030                 }
9031             }
9032         }
9033         $self->{MANPAGE} = $manpage if $manpage;
9034     }
9035     my($item);
9036     for $item (qw/MANPAGE/) {
9037         push @m, sprintf($sprintf, $item, $self->{$item})
9038             if exists $self->{$item};
9039     }
9040     for $item (qw/CONTAINS/) {
9041         push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
9042             if exists $self->{$item} && @{$self->{$item}};
9043     }
9044     push @m, sprintf($sprintf, 'INST_FILE',
9045                      $local_file || "(not installed)");
9046     push @m, sprintf($sprintf, 'INST_VERSION',
9047                      $self->inst_version) if $local_file;
9048     join "", @m, "\n";
9049 }
9050
9051 sub manpage_headline {
9052   my($self,$local_file) = @_;
9053   my(@local_file) = $local_file;
9054   $local_file =~ s/\.pm(?!\n)\Z/.pod/;
9055   push @local_file, $local_file;
9056   my(@result,$locf);
9057   for $locf (@local_file) {
9058     next unless -f $locf;
9059     my $fh = FileHandle->new($locf)
9060         or $Carp::Frontend->mydie("Couldn't open $locf: $!");
9061     my $inpod = 0;
9062     local $/ = "\n";
9063     while (<$fh>) {
9064       $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
9065           m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
9066       next unless $inpod;
9067       next if /^=/;
9068       next if /^\s+$/;
9069       chomp;
9070       push @result, $_;
9071     }
9072     close $fh;
9073     last if @result;
9074   }
9075   for (@result) {
9076       s/^\s+//;
9077       s/\s+$//;
9078   }
9079   join " ", @result;
9080 }
9081
9082 #-> sub CPAN::Module::cpan_file ;
9083 # Note: also inherited by CPAN::Bundle
9084 sub cpan_file {
9085     my $self = shift;
9086     # CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
9087     unless ($self->ro) {
9088         CPAN::Index->reload;
9089     }
9090     my $ro = $self->ro;
9091     if ($ro && defined $ro->{CPAN_FILE}){
9092         return $ro->{CPAN_FILE};
9093     } else {
9094         my $userid = $self->userid;
9095         if ( $userid ) {
9096             if ($CPAN::META->exists("CPAN::Author",$userid)) {
9097                 my $author = $CPAN::META->instance("CPAN::Author",
9098                                                    $userid);
9099                 my $fullname = $author->fullname;
9100                 my $email = $author->email;
9101                 unless (defined $fullname && defined $email) {
9102                     return sprintf("Contact Author %s",
9103                                    $userid,
9104                                   );
9105                 }
9106                 return "Contact Author $fullname <$email>";
9107             } else {
9108                 return "Contact Author $userid (Email address not available)";
9109             }
9110         } else {
9111             return "N/A";
9112         }
9113     }
9114 }
9115
9116 #-> sub CPAN::Module::cpan_version ;
9117 sub cpan_version {
9118     my $self = shift;
9119
9120     my $ro = $self->ro;
9121     unless ($ro) {
9122         # Can happen with modules that are not on CPAN
9123         $ro = {};
9124     }
9125     $ro->{CPAN_VERSION} = 'undef'
9126         unless defined $ro->{CPAN_VERSION};
9127     $ro->{CPAN_VERSION};
9128 }
9129
9130 #-> sub CPAN::Module::force ;
9131 sub force {
9132     my($self) = @_;
9133     $self->{force_update} = 1;
9134 }
9135
9136 #-> sub CPAN::Module::fforce ;
9137 sub fforce {
9138     my($self) = @_;
9139     $self->{force_update} = 2;
9140 }
9141
9142 sub notest {
9143     my($self) = @_;
9144     # warn "XDEBUG: set notest for Module";
9145     $self->{'notest'}++;
9146 }
9147
9148 #-> sub CPAN::Module::rematein ;
9149 sub rematein {
9150     my($self,$meth) = @_;
9151     $CPAN::Frontend->myprint(sprintf("Running %s for module '%s'\n",
9152                                      $meth,
9153                                      $self->id));
9154     my $cpan_file = $self->cpan_file;
9155     if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
9156       $CPAN::Frontend->mywarn(sprintf qq{
9157   The module %s isn\'t available on CPAN.
9158
9159   Either the module has not yet been uploaded to CPAN, or it is
9160   temporary unavailable. Please contact the author to find out
9161   more about the status. Try 'i %s'.
9162 },
9163                               $self->id,
9164                               $self->id,
9165                              );
9166       return;
9167     }
9168     my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
9169     $pack->called_for($self->id);
9170     if (exists $self->{force_update}){
9171         if ($self->{force_update} == 2) {
9172             $pack->fforce($meth);
9173         } else {
9174             $pack->force($meth);
9175         }
9176     }
9177     $pack->notest($meth) if exists $self->{'notest'};
9178
9179     $pack->{reqtype} ||= "";
9180     CPAN->debug("dist-reqtype[$pack->{reqtype}]".
9181                 "self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG;
9182         if ($pack->{reqtype}) {
9183             if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) {
9184                 $pack->{reqtype} = $self->{reqtype};
9185                 if (
9186                     exists $pack->{install}
9187                     &&
9188                     (
9189                      UNIVERSAL::can($pack->{install},"failed") ?
9190                      $pack->{install}->failed :
9191                      $pack->{install} =~ /^NO/
9192                     )
9193                    ) {
9194                     delete $pack->{install};
9195                     $CPAN::Frontend->mywarn
9196                         ("Promoting $pack->{ID} from 'build_requires' to 'requires'");
9197                 }
9198             }
9199         } else {
9200             $pack->{reqtype} = $self->{reqtype};
9201         }
9202
9203     eval {
9204         $pack->$meth();
9205     };
9206     my $err = $@;
9207     $pack->unforce if $pack->can("unforce") && exists $self->{force_update};
9208     $pack->unnotest if $pack->can("unnotest") && exists $self->{'notest'};
9209     delete $self->{force_update};
9210     delete $self->{'notest'};
9211     if ($err) {
9212         die $err;
9213     }
9214 }
9215
9216 #-> sub CPAN::Module::perldoc ;
9217 sub perldoc { shift->rematein('perldoc') }
9218 #-> sub CPAN::Module::readme ;
9219 sub readme  { shift->rematein('readme') }
9220 #-> sub CPAN::Module::look ;
9221 sub look    { shift->rematein('look') }
9222 #-> sub CPAN::Module::cvs_import ;
9223 sub cvs_import { shift->rematein('cvs_import') }
9224 #-> sub CPAN::Module::get ;
9225 sub get     { shift->rematein('get',@_) }
9226 #-> sub CPAN::Module::make ;
9227 sub make    { shift->rematein('make') }
9228 #-> sub CPAN::Module::test ;
9229 sub test   {
9230     my $self = shift;
9231     # $self->{badtestcnt} ||= 0;
9232     $self->rematein('test',@_);
9233 }
9234 #-> sub CPAN::Module::uptodate ;
9235 sub uptodate {
9236     my($self) = @_;
9237     local($_); # protect against a bug in MakeMaker 6.17
9238     my($latest) = $self->cpan_version;
9239     $latest ||= 0;
9240     my($inst_file) = $self->inst_file;
9241     my($have) = 0;
9242     if (defined $inst_file) {
9243         $have = $self->inst_version;
9244     }
9245     local($^W)=0;
9246     if ($inst_file
9247         &&
9248         ! CPAN::Version->vgt($latest, $have)
9249        ) {
9250         CPAN->debug("returning uptodate. inst_file[$inst_file] ".
9251                     "latest[$latest] have[$have]") if $CPAN::DEBUG;
9252         return 1;
9253     }
9254     return;
9255 }
9256 #-> sub CPAN::Module::install ;
9257 sub install {
9258     my($self) = @_;
9259     my($doit) = 0;
9260     if ($self->uptodate
9261         &&
9262         not exists $self->{force_update}
9263        ) {
9264         $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
9265                                          $self->id,
9266                                          $self->inst_version,
9267                                         ));
9268     } else {
9269         $doit = 1;
9270     }
9271     my $ro = $self->ro;
9272     if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
9273         $CPAN::Frontend->mywarn(qq{
9274 \n\n\n     ***WARNING***
9275      The module $self->{ID} has no active maintainer.\n\n\n
9276 });
9277         $CPAN::Frontend->mysleep(5);
9278     }
9279     $self->rematein('install') if $doit;
9280 }
9281 #-> sub CPAN::Module::clean ;
9282 sub clean  { shift->rematein('clean') }
9283
9284 #-> sub CPAN::Module::inst_file ;
9285 sub inst_file {
9286     my($self) = @_;
9287     $self->_file_in_path([@INC]);
9288 }
9289
9290 #-> sub CPAN::Module::available_file ;
9291 sub available_file {
9292     my($self) = @_;
9293     my $sep = $Config::Config{path_sep};
9294     my $perllib = $ENV{PERL5LIB};
9295     $perllib = $ENV{PERLLIB} unless defined $perllib;
9296     my @perllib = split(/$sep/,$perllib) if defined $perllib;
9297     $self->_file_in_path([@perllib,@INC]);
9298 }
9299
9300 #-> sub CPAN::Module::file_in_path ;
9301 sub _file_in_path {
9302     my($self,$path) = @_;
9303     my($dir,@packpath);
9304     @packpath = split /::/, $self->{ID};
9305     $packpath[-1] .= ".pm";
9306     if (@packpath == 1 && $packpath[0] eq "readline.pm") {
9307         unshift @packpath, "Term", "ReadLine"; # historical reasons
9308     }
9309     foreach $dir (@$path) {
9310         my $pmfile = File::Spec->catfile($dir,@packpath);
9311         if (-f $pmfile){
9312             return $pmfile;
9313         }
9314     }
9315     return;
9316 }
9317
9318 #-> sub CPAN::Module::xs_file ;
9319 sub xs_file {
9320     my($self) = @_;
9321     my($dir,@packpath);
9322     @packpath = split /::/, $self->{ID};
9323     push @packpath, $packpath[-1];
9324     $packpath[-1] .= "." . $Config::Config{'dlext'};
9325     foreach $dir (@INC) {
9326         my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
9327         if (-f $xsfile){
9328             return $xsfile;
9329         }
9330     }
9331     return;
9332 }
9333
9334 #-> sub CPAN::Module::inst_version ;
9335 sub inst_version {
9336     my($self) = @_;
9337     my $parsefile = $self->inst_file or return;
9338     my $have = $self->parse_version($parsefile);
9339     $have;
9340 }
9341
9342 #-> sub CPAN::Module::inst_version ;
9343 sub available_version {
9344     my($self) = @_;
9345     my $parsefile = $self->available_file or return;
9346     my $have = $self->parse_version($parsefile);
9347     $have;
9348 }
9349
9350 #-> sub CPAN::Module::parse_version ;
9351 sub parse_version {
9352     my($self,$parsefile) = @_;
9353     my $have = MM->parse_version($parsefile);
9354     $have = "undef" unless defined $have && length $have;
9355     $have =~ s/^ //; # since the %vd hack these two lines here are needed
9356     $have =~ s/ $//; # trailing whitespace happens all the time
9357
9358     $have = CPAN::Version->readable($have);
9359
9360     $have =~ s/\s*//g; # stringify to float around floating point issues
9361     $have; # no stringify needed, \s* above matches always
9362 }
9363
9364 package CPAN;
9365 use strict;
9366
9367 1;
9368
9369
9370 __END__
9371
9372 =head1 NAME
9373
9374 CPAN - query, download and build perl modules from CPAN sites
9375
9376 =head1 SYNOPSIS
9377
9378 Interactive mode:
9379
9380   perl -MCPAN -e shell
9381
9382 --or--
9383
9384   cpan
9385
9386 Basic commands:
9387
9388   # Modules:
9389
9390   cpan> install Acme::Meta                       # in the shell
9391
9392   CPAN::Shell->install("Acme::Meta");            # in perl
9393
9394   # Distributions:
9395
9396   cpan> install NWCLARK/Acme-Meta-0.02.tar.gz    # in the shell
9397
9398   CPAN::Shell->
9399     install("NWCLARK/Acme-Meta-0.02.tar.gz");    # in perl
9400
9401   # module objects:
9402
9403   $mo = CPAN::Shell->expandany($mod);
9404   $mo = CPAN::Shell->expand("Module",$mod);      # same thing
9405
9406   # distribution objects:
9407
9408   $do = CPAN::Shell->expand("Module",$mod)->distribution;
9409   $do = CPAN::Shell->expandany($distro);         # same thing
9410   $do = CPAN::Shell->expand("Distribution",
9411                             $distro);            # same thing
9412
9413 =head1 DESCRIPTION
9414
9415 The CPAN module automates or at least simplifies the make and install
9416 of perl modules and extensions. It includes some primitive searching
9417 capabilities and knows how to use Net::FTP or LWP or some external
9418 download clients to fetch the distributions from the net.
9419
9420 These are fetched from one or more of the mirrored CPAN (Comprehensive
9421 Perl Archive Network) sites and unpacked in a dedicated directory.
9422
9423 The CPAN module also supports the concept of named and versioned
9424 I<bundles> of modules. Bundles simplify the handling of sets of
9425 related modules. See Bundles below.
9426
9427 The package contains a session manager and a cache manager. The
9428 session manager keeps track of what has been fetched, built and
9429 installed in the current session. The cache manager keeps track of the
9430 disk space occupied by the make processes and deletes excess space
9431 according to a simple FIFO mechanism.
9432
9433 All methods provided are accessible in a programmer style and in an
9434 interactive shell style.
9435
9436 =head2 CPAN::shell([$prompt, $command]) Starting Interactive Mode
9437
9438 The interactive mode is entered by running
9439
9440     perl -MCPAN -e shell
9441
9442 or
9443
9444     cpan
9445
9446 which puts you into a readline interface. If C<Term::ReadKey> and
9447 either C<Term::ReadLine::Perl> or C<Term::ReadLine::Gnu> are installed
9448 it supports both history and command completion.
9449
9450 Once you are on the command line, type C<h> to get a one page help
9451 screen and the rest should be self-explanatory.
9452
9453 The function call C<shell> takes two optional arguments, one is the
9454 prompt, the second is the default initial command line (the latter
9455 only works if a real ReadLine interface module is installed).
9456
9457 The most common uses of the interactive modes are
9458
9459 =over 2
9460
9461 =item Searching for authors, bundles, distribution files and modules
9462
9463 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
9464 for each of the four categories and another, C<i> for any of the
9465 mentioned four. Each of the four entities is implemented as a class
9466 with slightly differing methods for displaying an object.
9467
9468 Arguments you pass to these commands are either strings exactly matching
9469 the identification string of an object or regular expressions that are
9470 then matched case-insensitively against various attributes of the
9471 objects. The parser recognizes a regular expression only if you
9472 enclose it between two slashes.
9473
9474 The principle is that the number of found objects influences how an
9475 item is displayed. If the search finds one item, the result is
9476 displayed with the rather verbose method C<as_string>, but if we find
9477 more than one, we display each object with the terse method
9478 C<as_glimpse>.
9479
9480 =item C<get>, C<make>, C<test>, C<install>, C<clean> modules or distributions
9481
9482 These commands take any number of arguments and investigate what is
9483 necessary to perform the action. If the argument is a distribution
9484 file name (recognized by embedded slashes), it is processed. If it is
9485 a module, CPAN determines the distribution file in which this module
9486 is included and processes that, following any dependencies named in
9487 the module's META.yml or Makefile.PL (this behavior is controlled by
9488 the configuration parameter C<prerequisites_policy>.)
9489
9490 C<get> downloads a distribution file and untars or unzips it, C<make>
9491 builds it, C<test> runs the test suite, and C<install> installs it.
9492
9493 Any C<make> or C<test> are run unconditionally. An
9494
9495   install <distribution_file>
9496
9497 also is run unconditionally. But for
9498
9499   install <module>
9500
9501 CPAN checks if an install is actually needed for it and prints
9502 I<module up to date> in the case that the distribution file containing
9503 the module doesn't need to be updated.
9504
9505 CPAN also keeps track of what it has done within the current session
9506 and doesn't try to build a package a second time regardless if it
9507 succeeded or not. It does not repeat a test run if the test
9508 has been run successfully before. Same for install runs.
9509
9510 The C<force> pragma may precede another command (currently: C<get>,
9511 C<make>, C<test>, or C<install>) and executes the command from scratch
9512 and tries to continue in case of some errors. See the section below on
9513 the C<force> and the C<fforce> pragma.
9514
9515 The C<notest> pragma may be used to skip the test part in the build
9516 process.
9517
9518 Example:
9519
9520     cpan> notest install Tk
9521
9522 A C<clean> command results in a
9523
9524   make clean
9525
9526 being executed within the distribution file's working directory.
9527
9528 =item C<readme>, C<perldoc>, C<look> module or distribution
9529
9530 C<readme> displays the README file of the associated distribution.
9531 C<Look> gets and untars (if not yet done) the distribution file,
9532 changes to the appropriate directory and opens a subshell process in
9533 that directory. C<perldoc> displays the pod documentation of the
9534 module in html or plain text format.
9535
9536 =item C<ls> author
9537
9538 =item C<ls> globbing_expression
9539
9540 The first form lists all distribution files in and below an author's
9541 CPAN directory as they are stored in the CHECKUMS files distributed on
9542 CPAN. The listing goes recursive into all subdirectories.
9543
9544 The second form allows to limit or expand the output with shell
9545 globbing as in the following examples:
9546
9547           ls JV/make*
9548           ls GSAR/*make*
9549           ls */*make*
9550
9551 The last example is very slow and outputs extra progress indicators
9552 that break the alignment of the result.
9553
9554 Note that globbing only lists directories explicitly asked for, for
9555 example FOO/* will not list FOO/bar/Acme-Sthg-n.nn.tar.gz. This may be
9556 regarded as a bug and may be changed in future versions.
9557
9558 =item C<failed>
9559
9560 The C<failed> command reports all distributions that failed on one of
9561 C<make>, C<test> or C<install> for some reason in the currently
9562 running shell session.
9563
9564 =item Persistence between sessions
9565
9566 If the C<YAML> or the c<YAML::Syck> module is installed a record of
9567 the internal state of all modules is written to disk after each step.
9568 The files contain a signature of the currently running perl version
9569 for later perusal.
9570
9571 If the configurations variable C<build_dir_reuse> is set to a true
9572 value, then CPAN.pm reads the collected YAML files. If the stored
9573 signature matches the currently running perl the stored state is
9574 loaded into memory such that effectively persistence between sessions
9575 is established.
9576
9577 =item The C<force> and the C<fforce> pragma
9578
9579 To speed things up in complex installation scenarios, CPAN.pm keeps
9580 track of what it has already done and refuses to do some things a
9581 second time. A C<get>, a C<make>, and an C<install> are not repeated.
9582 A C<test> is only repeated if the previous test was unsuccessful. The
9583 diagnostic message when CPAN.pm refuses to do something a second time
9584 is one of I<Has already been >C<unwrapped|made|tested successfully> or
9585 something similar. Another situation where CPAN refuses to act is an
9586 C<install> if the according C<test> was not successful.
9587
9588 In all these cases, the user can override the goatish behaviour by
9589 prepending the command with the word force, for example:
9590
9591   cpan> force get Foo
9592   cpan> force make AUTHOR/Bar-3.14.tar.gz
9593   cpan> force test Baz
9594   cpan> force install Acme::Meta
9595
9596 Each I<forced> command is executed with the according part of its
9597 memory erased.
9598
9599 The C<fforce> pragma is a variant that emulates a C<force get> which
9600 erases the entire memory followed by the action specified, effectively
9601 restarting the whole get/make/test/install procedure from scratch.
9602
9603 =item Lockfile
9604
9605 Interactive sessions maintain a lockfile, per default C<~/.cpan/.lock>.
9606 Batch jobs can run without a lockfile and do not disturb each other.
9607
9608 The shell offers to run in I<degraded mode> when another process is
9609 holding the lockfile. This is an experimental feature that is not yet
9610 tested very well. This second shell then does not write the history
9611 file, does not use the metadata file and has a different prompt.
9612
9613 =item Signals
9614
9615 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
9616 in the cpan-shell it is intended that you can press C<^C> anytime and
9617 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
9618 to clean up and leave the shell loop. You can emulate the effect of a
9619 SIGTERM by sending two consecutive SIGINTs, which usually means by
9620 pressing C<^C> twice.
9621
9622 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
9623 SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl
9624 Build.PL> subprocess.
9625
9626 =back
9627
9628 =head2 CPAN::Shell
9629
9630 The commands that are available in the shell interface are methods in
9631 the package CPAN::Shell. If you enter the shell command, all your
9632 input is split by the Text::ParseWords::shellwords() routine which
9633 acts like most shells do. The first word is being interpreted as the
9634 method to be called and the rest of the words are treated as arguments
9635 to this method. Continuation lines are supported if a line ends with a
9636 literal backslash.
9637
9638 =head2 autobundle
9639
9640 C<autobundle> writes a bundle file into the
9641 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
9642 a list of all modules that are both available from CPAN and currently
9643 installed within @INC. The name of the bundle file is based on the
9644 current date and a counter.
9645
9646 =head2 hosts
9647
9648 This commands provides a statistical overview over recent download
9649 activities. The data for this is collected in the YAML file
9650 C<FTPstats.yml> in your C<cpan_home> directory. If no YAML module is
9651 configured or YAML not installed, then no stats are provided.
9652
9653 =head2 mkmyconfig
9654
9655 mkmyconfig() writes your own CPAN::MyConfig file into your ~/.cpan/
9656 directory so that you can save your own preferences instead of the
9657 system wide ones.
9658
9659 =head2 recompile
9660
9661 recompile() is a very special command in that it takes no argument and
9662 runs the make/test/install cycle with brute force over all installed
9663 dynamically loadable extensions (aka XS modules) with 'force' in
9664 effect. The primary purpose of this command is to finish a network
9665 installation. Imagine, you have a common source tree for two different
9666 architectures. You decide to do a completely independent fresh
9667 installation. You start on one architecture with the help of a Bundle
9668 file produced earlier. CPAN installs the whole Bundle for you, but
9669 when you try to repeat the job on the second architecture, CPAN
9670 responds with a C<"Foo up to date"> message for all modules. So you
9671 invoke CPAN's recompile on the second architecture and you're done.
9672
9673 Another popular use for C<recompile> is to act as a rescue in case your
9674 perl breaks binary compatibility. If one of the modules that CPAN uses
9675 is in turn depending on binary compatibility (so you cannot run CPAN
9676 commands), then you should try the CPAN::Nox module for recovery.
9677
9678 =head2 report Bundle|Distribution|Module
9679
9680 The C<report> command temporarily turns on the C<test_report> config
9681 variable, then runs the C<force test> command with the given
9682 arguments. The C<force> pragma is used to re-run the tests and repeat
9683 every step that might have failed before.
9684
9685 =head2 upgrade [Module|/Regex/]...
9686
9687 The C<upgrade> command first runs an C<r> command with the given
9688 arguments and then installs the newest versions of all modules that
9689 were listed by that.
9690
9691 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
9692
9693 Although it may be considered internal, the class hierarchy does matter
9694 for both users and programmer. CPAN.pm deals with above mentioned four
9695 classes, and all those classes share a set of methods. A classical
9696 single polymorphism is in effect. A metaclass object registers all
9697 objects of all kinds and indexes them with a string. The strings
9698 referencing objects have a separated namespace (well, not completely
9699 separated):
9700
9701          Namespace                         Class
9702
9703    words containing a "/" (slash)      Distribution
9704     words starting with Bundle::          Bundle
9705           everything else            Module or Author
9706
9707 Modules know their associated Distribution objects. They always refer
9708 to the most recent official release. Developers may mark their releases
9709 as unstable development versions (by inserting an underbar into the
9710 module version number which will also be reflected in the distribution
9711 name when you run 'make dist'), so the really hottest and newest
9712 distribution is not always the default.  If a module Foo circulates
9713 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
9714 way to install version 1.23 by saying
9715
9716     install Foo
9717
9718 This would install the complete distribution file (say
9719 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
9720 like to install version 1.23_90, you need to know where the
9721 distribution file resides on CPAN relative to the authors/id/
9722 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
9723 so you would have to say
9724
9725     install BAR/Foo-1.23_90.tar.gz
9726
9727 The first example will be driven by an object of the class
9728 CPAN::Module, the second by an object of class CPAN::Distribution.
9729
9730 =head2 Integrating local directories
9731
9732 Distribution objects are normally distributions from the CPAN, but
9733 there is a slightly degenerate case for Distribution objects, too, of
9734 projects held on the local disk. These distribution objects have the
9735 same name as the local directory and end with a dot. A dot by itself
9736 is also allowed for the current directory at the time CPAN.pm was
9737 used. All actions such as C<make>, C<test>, and C<install> are applied
9738 directly to that directory. This gives the command C<cpan .> an
9739 interesting touch: while the normal mantra of installing a CPAN module
9740 without CPAN.pm is one of
9741
9742     perl Makefile.PL                 perl Build.PL
9743            ( go and get prerequisites )
9744     make                             ./Build
9745     make test                        ./Build test
9746     make install                     ./Build install
9747
9748 the command C<cpan .> does all of this at once. It figures out which
9749 of the two mantras is appropriate, fetches and installs all
9750 prerequisites, cares for them recursively and finally finishes the
9751 installation of the module in the current directory, be it a CPAN
9752 module or not.
9753
9754 The typical usage case is for private modules or working copies of
9755 projects from remote repositories on the local disk.
9756
9757 =head1 CONFIGURATION
9758
9759 When the CPAN module is used for the first time, a configuration
9760 dialog tries to determine a couple of site specific options. The
9761 result of the dialog is stored in a hash reference C< $CPAN::Config >
9762 in a file CPAN/Config.pm.
9763
9764 The default values defined in the CPAN/Config.pm file can be
9765 overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
9766 best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
9767 added to the search path of the CPAN module before the use() or
9768 require() statements. The mkmyconfig command writes this file for you.
9769
9770 The C<o conf> command has various bells and whistles:
9771
9772 =over
9773
9774 =item completion support
9775
9776 If you have a ReadLine module installed, you can hit TAB at any point
9777 of the commandline and C<o conf> will offer you completion for the
9778 built-in subcommands and/or config variable names.
9779
9780 =item displaying some help: o conf help
9781
9782 Displays a short help
9783
9784 =item displaying current values: o conf [KEY]
9785
9786 Displays the current value(s) for this config variable. Without KEY
9787 displays all subcommands and config variables.
9788
9789 Example:
9790
9791   o conf shell
9792
9793 =item changing of scalar values: o conf KEY VALUE
9794
9795 Sets the config variable KEY to VALUE. The empty string can be
9796 specified as usual in shells, with C<''> or C<"">
9797
9798 Example:
9799
9800   o conf wget /usr/bin/wget
9801
9802 =item changing of list values: o conf KEY SHIFT|UNSHIFT|PUSH|POP|SPLICE|LIST
9803
9804 If a config variable name ends with C<list>, it is a list. C<o conf
9805 KEY shift> removes the first element of the list, C<o conf KEY pop>
9806 removes the last element of the list. C<o conf KEYS unshift LIST>
9807 prepends a list of values to the list, C<o conf KEYS push LIST>
9808 appends a list of valued to the list.
9809
9810 Likewise, C<o conf KEY splice LIST> passes the LIST to the according
9811 splice command.
9812
9813 Finally, any other list of arguments is taken as a new list value for
9814 the KEY variable discarding the previous value.
9815
9816 Examples:
9817
9818   o conf urllist unshift http://cpan.dev.local/CPAN
9819   o conf urllist splice 3 1
9820   o conf urllist http://cpan1.local http://cpan2.local ftp://ftp.perl.org
9821
9822 =item reverting to saved: o conf defaults
9823
9824 Reverts all config variables to the state in the saved config file.
9825
9826 =item saving the config: o conf commit
9827
9828 Saves all config variables to the current config file (CPAN/Config.pm
9829 or CPAN/MyConfig.pm that was loaded at start).
9830
9831 =back
9832
9833 The configuration dialog can be started any time later again by
9834 issuing the command C< o conf init > in the CPAN shell. A subset of
9835 the configuration dialog can be run by issuing C<o conf init WORD>
9836 where WORD is any valid config variable or a regular expression.
9837
9838 =head2 Config Variables
9839
9840 Currently the following keys in the hash reference $CPAN::Config are
9841 defined:
9842
9843   applypatch         path to external prg
9844   auto_commit        commit all changes to config variables to disk
9845   build_cache        size of cache for directories to build modules
9846   build_dir          locally accessible directory to build modules
9847   build_dir_reuse    boolean if distros in build_dir are persistent
9848   build_requires_install_policy
9849                      to install or not to install when a module is
9850                      only needed for building. yes|no|ask/yes|ask/no
9851   bzip2              path to external prg
9852   cache_metadata     use serializer to cache metadata
9853   commands_quote     prefered character to use for quoting external
9854                      commands when running them. Defaults to double
9855                      quote on Windows, single tick everywhere else;
9856                      can be set to space to disable quoting
9857   check_sigs         if signatures should be verified
9858   colorize_debug     Term::ANSIColor attributes for debugging output
9859   colorize_output    boolean if Term::ANSIColor should colorize output
9860   colorize_print     Term::ANSIColor attributes for normal output
9861   colorize_warn      Term::ANSIColor attributes for warnings
9862   commandnumber_in_prompt
9863                      boolean if you want to see current command number
9864   cpan_home          local directory reserved for this package
9865   curl               path to external prg
9866   dontload_hash      DEPRECATED
9867   dontload_list      arrayref: modules in the list will not be
9868                      loaded by the CPAN::has_inst() routine
9869   ftp                path to external prg
9870   ftp_passive        if set, the envariable FTP_PASSIVE is set for downloads
9871   ftp_proxy          proxy host for ftp requests
9872   getcwd             see below
9873   gpg                path to external prg
9874   gzip               location of external program gzip
9875   histfile           file to maintain history between sessions
9876   histsize           maximum number of lines to keep in histfile
9877   http_proxy         proxy host for http requests
9878   inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
9879                      after this many seconds inactivity. Set to 0 to
9880                      never break.
9881   index_expire       after this many days refetch index files
9882   inhibit_startup_message
9883                      if true, does not print the startup message
9884   keep_source_where  directory in which to keep the source (if we do)
9885   lynx               path to external prg
9886   make               location of external make program
9887   make_arg           arguments that should always be passed to 'make'
9888   make_install_make_command
9889                      the make command for running 'make install', for
9890                      example 'sudo make'
9891   make_install_arg   same as make_arg for 'make install'
9892   makepl_arg         arguments passed to 'perl Makefile.PL'
9893   mbuild_arg         arguments passed to './Build'
9894   mbuild_install_arg arguments passed to './Build install'
9895   mbuild_install_build_command
9896                      command to use instead of './Build' when we are
9897                      in the install stage, for example 'sudo ./Build'
9898   mbuildpl_arg       arguments passed to 'perl Build.PL'
9899   ncftp              path to external prg
9900   ncftpget           path to external prg
9901   no_proxy           don't proxy to these hosts/domains (comma separated list)
9902   pager              location of external program more (or any pager)
9903   password           your password if you CPAN server wants one
9904   patch              path to external prg
9905   prefer_installer   legal values are MB and EUMM: if a module comes
9906                      with both a Makefile.PL and a Build.PL, use the
9907                      former (EUMM) or the latter (MB); if the module
9908                      comes with only one of the two, that one will be
9909                      used in any case
9910   prerequisites_policy
9911                      what to do if you are missing module prerequisites
9912                      ('follow' automatically, 'ask' me, or 'ignore')
9913   prefs_dir          local directory to store per-distro build options
9914   proxy_user         username for accessing an authenticating proxy
9915   proxy_pass         password for accessing an authenticating proxy
9916   randomize_urllist  add some randomness to the sequence of the urllist
9917   scan_cache         controls scanning of cache ('atstart' or 'never')
9918   shell              your favorite shell
9919   show_upload_date   boolean if commands should try to determine upload date
9920   tar                location of external program tar
9921   term_is_latin      if true internal UTF-8 is translated to ISO-8859-1
9922                      (and nonsense for characters outside latin range)
9923   term_ornaments     boolean to turn ReadLine ornamenting on/off
9924   test_report        email test reports (if CPAN::Reporter is installed)
9925   unzip              location of external program unzip
9926   urllist            arrayref to nearby CPAN sites (or equivalent locations)
9927   use_sqlite         use CPAN::SQLite for metadata storage (fast and lean)
9928   username           your username if you CPAN server wants one
9929   wait_list          arrayref to a wait server to try (See CPAN::WAIT)
9930   wget               path to external prg
9931   yaml_module        which module to use to read/write YAML files
9932
9933 You can set and query each of these options interactively in the cpan
9934 shell with the C<o conf> or the C<o conf init> command as specified below.
9935
9936 =over 2
9937
9938 =item C<o conf E<lt>scalar optionE<gt>>
9939
9940 prints the current value of the I<scalar option>
9941
9942 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
9943
9944 Sets the value of the I<scalar option> to I<value>
9945
9946 =item C<o conf E<lt>list optionE<gt>>
9947
9948 prints the current value of the I<list option> in MakeMaker's
9949 neatvalue format.
9950
9951 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
9952
9953 shifts or pops the array in the I<list option> variable
9954
9955 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
9956
9957 works like the corresponding perl commands.
9958
9959 =item interactive editing: o conf init [MATCH|LIST]
9960
9961 Runs an interactive configuration dialog for matching variables.
9962 Without argument runs the dialog over all supported config variables.
9963 To specify a MATCH the argument must be enclosed by slashes.
9964
9965 Examples:
9966
9967   o conf init ftp_passive ftp_proxy
9968   o conf init /color/
9969
9970 Note: this method of setting config variables often provides more
9971 explanation about the functioning of a variable than the manpage.
9972
9973 =back
9974
9975 =head2 CPAN::anycwd($path): Note on config variable getcwd
9976
9977 CPAN.pm changes the current working directory often and needs to
9978 determine its own current working directory. Per default it uses
9979 Cwd::cwd but if this doesn't work on your system for some reason,
9980 alternatives can be configured according to the following table:
9981
9982 =over 4
9983
9984 =item cwd
9985
9986 Calls Cwd::cwd
9987
9988 =item getcwd
9989
9990 Calls Cwd::getcwd
9991
9992 =item fastcwd
9993
9994 Calls Cwd::fastcwd
9995
9996 =item backtickcwd
9997
9998 Calls the external command cwd.
9999
10000 =back
10001
10002 =head2 Note on the format of the urllist parameter
10003
10004 urllist parameters are URLs according to RFC 1738. We do a little
10005 guessing if your URL is not compliant, but if you have problems with
10006 C<file> URLs, please try the correct format. Either:
10007
10008     file://localhost/whatever/ftp/pub/CPAN/
10009
10010 or
10011
10012     file:///home/ftp/pub/CPAN/
10013
10014 =head2 The urllist parameter has CD-ROM support
10015
10016 The C<urllist> parameter of the configuration table contains a list of
10017 URLs that are to be used for downloading. If the list contains any
10018 C<file> URLs, CPAN always tries to get files from there first. This
10019 feature is disabled for index files. So the recommendation for the
10020 owner of a CD-ROM with CPAN contents is: include your local, possibly
10021 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
10022
10023   o conf urllist push file://localhost/CDROM/CPAN
10024
10025 CPAN.pm will then fetch the index files from one of the CPAN sites
10026 that come at the beginning of urllist. It will later check for each
10027 module if there is a local copy of the most recent version.
10028
10029 Another peculiarity of urllist is that the site that we could
10030 successfully fetch the last file from automatically gets a preference
10031 token and is tried as the first site for the next request. So if you
10032 add a new site at runtime it may happen that the previously preferred
10033 site will be tried another time. This means that if you want to disallow
10034 a site for the next transfer, it must be explicitly removed from
10035 urllist.
10036
10037 =head2 Maintaining the urllist parameter
10038
10039 If you have YAML.pm (or some other YAML module configured in
10040 C<yaml_module>) installed, CPAN.pm collects a few statistical data
10041 about recent downloads. You can view the statistics with the C<hosts>
10042 command or inspect them directly by looking into the C<FTPstats.yml>
10043 file in your C<cpan_home> directory.
10044
10045 To get some interesting statistics it is recommended to set the
10046 C<randomize_urllist> parameter that introduces some amount of
10047 randomness into the URL selection.
10048
10049 =head2 The C<requires> and C<build_requires> dependency declarations
10050
10051 Since CPAN.pm version 1.88_51 modules declared as C<build_requires> by
10052 a distribution are treated differently depending on the config
10053 variable C<build_requires_install_policy>. By setting
10054 C<build_requires_install_policy> to C<no> such a module is not being
10055 installed. It is only built and tested and then kept in the list of
10056 tested but uninstalled modules. As such it is available during the
10057 build of the dependent module by integrating the path to the
10058 C<blib/arch> and C<blib/lib> directories in the environment variable
10059 PERL5LIB. If C<build_requires_install_policy> is set ti C<yes>, then
10060 both modules declared as C<requires> and those declared as
10061 C<build_requires> are treated alike. By setting to C<ask/yes> or
10062 C<ask/no>, CPAN.pm asks the user and sets the default accordingly.
10063
10064 =head2 Configuration for individual distributions (I<Distroprefs>)
10065
10066 (B<Note:> This feature has been introduced in CPAN.pm 1.8854 and is
10067 still considered beta quality)
10068
10069 Distributions on the CPAN usually behave according to what we call the
10070 CPAN mantra. Or since the event of Module::Build we should talk about
10071 two mantras:
10072
10073     perl Makefile.PL     perl Build.PL
10074     make                 ./Build
10075     make test            ./Build test
10076     make install         ./Build install
10077
10078 But some modules cannot be built with this mantra. They try to get
10079 some extra data from the user via the environment, extra arguments or
10080 interactively thus disturbing the installation of large bundles like
10081 Phalanx100 or modules with many dependencies like Plagger.
10082
10083 The distroprefs system of C<CPAN.pm> addresses this problem by
10084 allowing the user to specify extra informations and recipes in YAML
10085 files to either
10086
10087 =over
10088
10089 =item
10090
10091 pass additional arguments to one of the four commands,
10092
10093 =item
10094
10095 set environment variables
10096
10097 =item
10098
10099 instantiate an Expect object that reads from the console, waits for
10100 some regular expressions and enters some answers
10101
10102 =item
10103
10104 temporarily override assorted C<CPAN.pm> configuration variables
10105
10106 =item
10107
10108 disable the installation of an object altogether
10109
10110 =back
10111
10112 See the YAML and Data::Dumper files that come with the C<CPAN.pm>
10113 distribution in the C<distroprefs/> directory for examples.
10114
10115 =head2 Filenames
10116
10117 The YAML files themselves must have the C<.yml> extension, all other
10118 files are ignored (for two exceptions see I<Fallback Data::Dumper and
10119 Storable> below). The containing directory can be specified in
10120 C<CPAN.pm> in the C<prefs_dir> config variable. Try C<o conf init
10121 prefs_dir> in the CPAN shell to set and activate the distroprefs
10122 system.
10123
10124 Every YAML file may contain arbitrary documents according to the YAML
10125 specification and every single document is treated as an entity that
10126 can specify the treatment of a single distribution.
10127
10128 The names of the files can be picked freely, C<CPAN.pm> always reads
10129 all files (in alphabetical order) and takes the key C<match> (see
10130 below in I<Language Specs>) as a hashref containing match criteria
10131 that determine if the current distribution matches the YAML document
10132 or not.
10133
10134 =head2 Fallback Data::Dumper and Storable
10135
10136 If neither your configured C<yaml_module> nor YAML.pm is installed
10137 CPAN.pm falls back to using Data::Dumper and Storable and looks for
10138 files with the extensions C<.dd> or C<.st> in the C<prefs_dir>
10139 directory. These files are expected to contain one or more hashrefs.
10140 For Data::Dumper generated files, this is expected to be done with by
10141 defining C<$VAR1>, C<$VAR2>, etc. The YAML shell would produce these
10142 with the command
10143
10144     ysh < somefile.yml > somefile.dd
10145
10146 For Storable files the rule is that they must be constructed such that
10147 C<Storable::retrieve(file)> returns an array reference and the array
10148 elements represent one distropref object each. The conversion from
10149 YAML would look like so:
10150
10151     perl -MYAML=LoadFile -MStorable=nstore -e '
10152         @y=LoadFile(shift);
10153         nstore(\@y, shift)' somefile.yml somefile.st
10154
10155 In bootstrapping situations it is usually sufficient to translate only
10156 a few YAML files to Data::Dumper for the crucial modules like
10157 C<YAML::Syck>, C<YAML.pm> and C<Expect.pm>. If you prefer Storable
10158 over Data::Dumper, remember to pull out a Storable version that writes
10159 an older format than all the other Storable versions that will need to
10160 read them.
10161
10162 =head2 Blueprint
10163
10164 The following example contains all supported keywords and structures
10165 with the exception of C<eexpect> which can be used instead of
10166 C<expect>.
10167
10168   ---
10169   comment: "Demo"
10170   match:
10171     module: "Dancing::Queen"
10172     distribution: "^CHACHACHA/Dancing-"
10173     perl: "/usr/local/cariba-perl/bin/perl"
10174   disabled: 1
10175   cpanconfig:
10176     make: gmake
10177   pl:
10178     args:
10179       - "--somearg=specialcase"
10180
10181     env: {}
10182
10183     expect:
10184       - "Which is your favorite fruit"
10185       - "apple\n"
10186
10187   make:
10188     args:
10189       - all
10190       - extra-all
10191
10192     env: {}
10193
10194     expect: []
10195
10196     commendline: "echo SKIPPING make"
10197
10198   test:
10199     args: []
10200
10201     env: {}
10202
10203     expect: []
10204
10205   install:
10206     args: []
10207
10208     env:
10209       WANT_TO_INSTALL: YES
10210
10211     expect:
10212       - "Do you really want to install"
10213       - "y\n"
10214
10215   patches:
10216     - "ABCDE/Fedcba-3.14-ABCDE-01.patch"
10217
10218
10219 =head2 Language Specs
10220
10221 Every YAML document represents a single hash reference. The valid keys
10222 in this hash are as follows:
10223
10224 =over
10225
10226 =item comment [scalar]
10227
10228 A comment
10229
10230 =item cpanconfig [hash]
10231
10232 Temporarily override assorted C<CPAN.pm> configuration variables.
10233
10234 Supported are: C<build_requires_install_policy>, C<check_sigs>,
10235 C<make>, C<make_install_make_command>, C<prefer_installer>,
10236 C<test_report>. Please report as a bug when you need another one
10237 supported.
10238
10239 =item disabled [boolean]
10240
10241 Specifies that this distribution shall not be processed at all.
10242
10243 =item goto [string]
10244
10245 The canonical name of a delegate distribution that shall be installed
10246 instead. Useful when a new version, although it tests OK itself,
10247 breaks something else or a developer release or a fork is already
10248 uploaded that is better than the last released version.
10249
10250 =item install [hash]
10251
10252 Processing instructions for the C<make install> or C<./Build install>
10253 phase of the CPAN mantra. See below under I<Processiong Instructions>.
10254
10255 =item make [hash]
10256
10257 Processing instructions for the C<make> or C<./Build> phase of the
10258 CPAN mantra. See below under I<Processiong Instructions>.
10259
10260 =item match [hash]
10261
10262 A hashref with one or more of the keys C<distribution>, C<modules>, or
10263 C<perl> that specify if a document is targeted at a specific CPAN
10264 distribution.
10265
10266 The corresponding values are interpreted as regular expressions. The
10267 C<distribution> related one will be matched against the canonical
10268 distribution name, e.g. "AUTHOR/Foo-Bar-3.14.tar.gz".
10269
10270 The C<module> related one will be matched against I<all> modules
10271 contained in the distribution until one module matches.
10272
10273 The C<perl> related one will be matched against C<$^X>.
10274
10275 If more than one restriction of C<module>, C<distribution>, and
10276 C<perl> is specified, the results of the separately computed match
10277 values must all match. If this is the case then the hashref
10278 represented by the YAML document is returned as the preference
10279 structure for the current distribution.
10280
10281 =item patches [array]
10282
10283 An array of patches on CPAN or on the local disk to be applied in
10284 order via the external patch program. If the value for the C<-p>
10285 parameter is C<0> or C<1> is determined by reading the patch
10286 beforehand.
10287
10288 Note: if the C<applypatch> program is installed and C<CPAN::Config>
10289 knows about it B<and> a patch is written by the C<makepatch> program,
10290 then C<CPAN.pm> lets C<applypatch> apply the patch. Both C<makepatch>
10291 and C<applypatch> are available from CPAN in the C<JV/makepatch-*>
10292 distribution.
10293
10294 =item pl [hash]
10295
10296 Processing instructions for the C<perl Makefile.PL> or C<perl
10297 Build.PL> phase of the CPAN mantra. See below under I<Processiong
10298 Instructions>.
10299
10300 =item test [hash]
10301
10302 Processing instructions for the C<make test> or C<./Build test> phase
10303 of the CPAN mantra. See below under I<Processiong Instructions>.
10304
10305 =back
10306
10307 =head2 Processing Instructions
10308
10309 =over
10310
10311 =item args [array]
10312
10313 Arguments to be added to the command line
10314
10315 =item commandline
10316
10317 A full commandline that will be executed as it stands by a system
10318 call. During the execution the environment variable PERL will is set
10319 to $^X. If C<commandline> is specified, the content of C<args> is not
10320 used.
10321
10322 =item eexpect [hash]
10323
10324 Extended C<expect>. This is a hash reference with three allowed keys,
10325 C<mode>, C<timeout>, and C<talk>.
10326
10327 C<mode> may have the values C<deterministic> for the case where all
10328 questions come in the order written down and C<anyorder> for the case
10329 where the questions may come in any order. The default mode is
10330 C<deterministic>.
10331
10332 C<timeout> denotes a timeout in seconds. Floating point timeouts are
10333 OK. In the case of a C<mode=deterministic> the timeout denotes the
10334 timeout per question, in the case of C<mode=anyorder> it denotes the
10335 timeout per byte received from the stream or questions.
10336
10337 C<talk> is a reference to an array that contains alternating questions
10338 and answers. Questions are regular expressions and answers are literal
10339 strings. The Expect module will then watch the stream coming from the
10340 execution of the external program (C<perl Makefile.PL>, C<perl
10341 Build.PL>, C<make>, etc.).
10342
10343 In the case of C<mode=deterministic> the CPAN.pm will inject the
10344 according answer as soon as the stream matches the regular expression.
10345 In the case of C<mode=anyorder> the CPAN.pm will answer a question as
10346 soon as the timeout is reached for the next byte in the input stream.
10347 In the latter case it removes the according question/answer pair from
10348 the array, so if you want to answer the question C<Do you really want
10349 to do that> several times, then it must be included in the array at
10350 least as often as you want this answer to be given.
10351
10352 =item env [hash]
10353
10354 Environment variables to be set during the command
10355
10356 =item expect [array]
10357
10358 C<< expect: <array> >> is a short notation for
10359
10360   eexpect:
10361     mode: deterministic
10362     timeout: 15
10363     talk: <array>
10364
10365 =back
10366
10367 =head2 Schema verification with C<Kwalify>
10368
10369 If you have the C<Kwalify> module installed (which is part of the
10370 Bundle::CPANxxl), then all your distroprefs files are checked for
10371 syntactical correctness.
10372
10373 =head2 Example Distroprefs Files
10374
10375 C<CPAN.pm> comes with a collection of example YAML files. Note that these
10376 are really just examples and should not be used without care because
10377 they cannot fit everybody's purpose. After all the authors of the
10378 packages that ask questions had a need to ask, so you should watch
10379 their questions and adjust the examples to your environment and your
10380 needs. You have beend warned:-)
10381
10382 =head1 PROGRAMMER'S INTERFACE
10383
10384 If you do not enter the shell, the available shell commands are both
10385 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
10386 functions in the calling package (C<install(...)>).  Before calling low-level
10387 commands it makes sense to initialize components of CPAN you need, e.g.:
10388
10389   CPAN::HandleConfig->load;
10390   CPAN::Shell::setup_output;
10391   CPAN::Index->reload;
10392
10393 High-level commands do such initializations automatically.
10394
10395 There's currently only one class that has a stable interface -
10396 CPAN::Shell. All commands that are available in the CPAN shell are
10397 methods of the class CPAN::Shell. Each of the commands that produce
10398 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
10399 the IDs of all modules within the list.
10400
10401 =over 2
10402
10403 =item expand($type,@things)
10404
10405 The IDs of all objects available within a program are strings that can
10406 be expanded to the corresponding real objects with the
10407 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
10408 list of CPAN::Module objects according to the C<@things> arguments
10409 given. In scalar context it only returns the first element of the
10410 list.
10411
10412 =item expandany(@things)
10413
10414 Like expand, but returns objects of the appropriate type, i.e.
10415 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
10416 CPAN::Distribution objects for distributions. Note: it does not expand
10417 to CPAN::Author objects.
10418
10419 =item Programming Examples
10420
10421 This enables the programmer to do operations that combine
10422 functionalities that are available in the shell.
10423
10424     # install everything that is outdated on my disk:
10425     perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
10426
10427     # install my favorite programs if necessary:
10428     for $mod (qw(Net::FTP Digest::SHA Data::Dumper)){
10429         CPAN::Shell->install($mod);
10430     }
10431
10432     # list all modules on my disk that have no VERSION number
10433     for $mod (CPAN::Shell->expand("Module","/./")){
10434         next unless $mod->inst_file;
10435         # MakeMaker convention for undefined $VERSION:
10436         next unless $mod->inst_version eq "undef";
10437         print "No VERSION in ", $mod->id, "\n";
10438     }
10439
10440     # find out which distribution on CPAN contains a module:
10441     print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
10442
10443 Or if you want to write a cronjob to watch The CPAN, you could list
10444 all modules that need updating. First a quick and dirty way:
10445
10446     perl -e 'use CPAN; CPAN::Shell->r;'
10447
10448 If you don't want to get any output in the case that all modules are
10449 up to date, you can parse the output of above command for the regular
10450 expression //modules are up to date// and decide to mail the output
10451 only if it doesn't match. Ick?
10452
10453 If you prefer to do it more in a programmer style in one single
10454 process, maybe something like this suits you better:
10455
10456   # list all modules on my disk that have newer versions on CPAN
10457   for $mod (CPAN::Shell->expand("Module","/./")){
10458     next unless $mod->inst_file;
10459     next if $mod->uptodate;
10460     printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
10461         $mod->id, $mod->inst_version, $mod->cpan_version;
10462   }
10463
10464 If that gives you too much output every day, you maybe only want to
10465 watch for three modules. You can write
10466
10467   for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
10468
10469 as the first line instead. Or you can combine some of the above
10470 tricks:
10471
10472   # watch only for a new mod_perl module
10473   $mod = CPAN::Shell->expand("Module","mod_perl");
10474   exit if $mod->uptodate;
10475   # new mod_perl arrived, let me know all update recommendations
10476   CPAN::Shell->r;
10477
10478 =back
10479
10480 =head2 Methods in the other Classes
10481
10482 =over 4
10483
10484 =item CPAN::Author::as_glimpse()
10485
10486 Returns a one-line description of the author
10487
10488 =item CPAN::Author::as_string()
10489
10490 Returns a multi-line description of the author
10491
10492 =item CPAN::Author::email()
10493
10494 Returns the author's email address
10495
10496 =item CPAN::Author::fullname()
10497
10498 Returns the author's name
10499
10500 =item CPAN::Author::name()
10501
10502 An alias for fullname
10503
10504 =item CPAN::Bundle::as_glimpse()
10505
10506 Returns a one-line description of the bundle
10507
10508 =item CPAN::Bundle::as_string()
10509
10510 Returns a multi-line description of the bundle
10511
10512 =item CPAN::Bundle::clean()
10513
10514 Recursively runs the C<clean> method on all items contained in the bundle.
10515
10516 =item CPAN::Bundle::contains()
10517
10518 Returns a list of objects' IDs contained in a bundle. The associated
10519 objects may be bundles, modules or distributions.
10520
10521 =item CPAN::Bundle::force($method,@args)
10522
10523 Forces CPAN to perform a task that it normally would have refused to
10524 do. Force takes as arguments a method name to be called and any number
10525 of additional arguments that should be passed to the called method.
10526 The internals of the object get the needed changes so that CPAN.pm
10527 does not refuse to take the action. The C<force> is passed recursively
10528 to all contained objects. See also the section above on the C<force>
10529 and the C<fforce> pragma.
10530
10531 =item CPAN::Bundle::get()
10532
10533 Recursively runs the C<get> method on all items contained in the bundle
10534
10535 =item CPAN::Bundle::inst_file()
10536
10537 Returns the highest installed version of the bundle in either @INC or
10538 C<$CPAN::Config->{cpan_home}>. Note that this is different from
10539 CPAN::Module::inst_file.
10540
10541 =item CPAN::Bundle::inst_version()
10542
10543 Like CPAN::Bundle::inst_file, but returns the $VERSION
10544
10545 =item CPAN::Bundle::uptodate()
10546
10547 Returns 1 if the bundle itself and all its members are uptodate.
10548
10549 =item CPAN::Bundle::install()
10550
10551 Recursively runs the C<install> method on all items contained in the bundle
10552
10553 =item CPAN::Bundle::make()
10554
10555 Recursively runs the C<make> method on all items contained in the bundle
10556
10557 =item CPAN::Bundle::readme()
10558
10559 Recursively runs the C<readme> method on all items contained in the bundle
10560
10561 =item CPAN::Bundle::test()
10562
10563 Recursively runs the C<test> method on all items contained in the bundle
10564
10565 =item CPAN::Distribution::as_glimpse()
10566
10567 Returns a one-line description of the distribution
10568
10569 =item CPAN::Distribution::as_string()
10570
10571 Returns a multi-line description of the distribution
10572
10573 =item CPAN::Distribution::author
10574
10575 Returns the CPAN::Author object of the maintainer who uploaded this
10576 distribution
10577
10578 =item CPAN::Distribution::clean()
10579
10580 Changes to the directory where the distribution has been unpacked and
10581 runs C<make clean> there.
10582
10583 =item CPAN::Distribution::containsmods()
10584
10585 Returns a list of IDs of modules contained in a distribution file.
10586 Only works for distributions listed in the 02packages.details.txt.gz
10587 file. This typically means that only the most recent version of a
10588 distribution is covered.
10589
10590 =item CPAN::Distribution::cvs_import()
10591
10592 Changes to the directory where the distribution has been unpacked and
10593 runs something like
10594
10595     cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
10596
10597 there.
10598
10599 =item CPAN::Distribution::dir()
10600
10601 Returns the directory into which this distribution has been unpacked.
10602
10603 =item CPAN::Distribution::force($method,@args)
10604
10605 Forces CPAN to perform a task that it normally would have refused to
10606 do. Force takes as arguments a method name to be called and any number
10607 of additional arguments that should be passed to the called method.
10608 The internals of the object get the needed changes so that CPAN.pm
10609 does not refuse to take the action. See also the section above on the
10610 C<force> and the C<fforce> pragma.
10611
10612 =item CPAN::Distribution::get()
10613
10614 Downloads the distribution from CPAN and unpacks it. Does nothing if
10615 the distribution has already been downloaded and unpacked within the
10616 current session.
10617
10618 =item CPAN::Distribution::install()
10619
10620 Changes to the directory where the distribution has been unpacked and
10621 runs the external command C<make install> there. If C<make> has not
10622 yet been run, it will be run first. A C<make test> will be issued in
10623 any case and if this fails, the install will be canceled. The
10624 cancellation can be avoided by letting C<force> run the C<install> for
10625 you.
10626
10627 This install method has only the power to install the distribution if
10628 there are no dependencies in the way. To install an object and all of
10629 its dependencies, use CPAN::Shell->install.
10630
10631 Note that install() gives no meaningful return value. See uptodate().
10632
10633 =item CPAN::Distribution::install_tested()
10634
10635 Install all the distributions that have been tested sucessfully but
10636 not yet installed. See also C<is_tested>.
10637
10638 =item CPAN::Distribution::isa_perl()
10639
10640 Returns 1 if this distribution file seems to be a perl distribution.
10641 Normally this is derived from the file name only, but the index from
10642 CPAN can contain a hint to achieve a return value of true for other
10643 filenames too.
10644
10645 =item CPAN::Distribution::is_tested()
10646
10647 List all the distributions that have been tested sucessfully but not
10648 yet installed. See also C<install_tested>.
10649
10650 =item CPAN::Distribution::look()
10651
10652 Changes to the directory where the distribution has been unpacked and
10653 opens a subshell there. Exiting the subshell returns.
10654
10655 =item CPAN::Distribution::make()
10656
10657 First runs the C<get> method to make sure the distribution is
10658 downloaded and unpacked. Changes to the directory where the
10659 distribution has been unpacked and runs the external commands C<perl
10660 Makefile.PL> or C<perl Build.PL> and C<make> there.
10661
10662 =item CPAN::Distribution::perldoc()
10663
10664 Downloads the pod documentation of the file associated with a
10665 distribution (in html format) and runs it through the external
10666 command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
10667 isn't available, it converts it to plain text with external
10668 command html2text and runs it through the pager specified
10669 in C<$CPAN::Config->{pager}>
10670
10671 =item CPAN::Distribution::prefs()
10672
10673 Returns the hash reference from the first matching YAML file that the
10674 user has deposited in the C<prefs_dir/> directory. The first
10675 succeeding match wins. The files in the C<prefs_dir/> are processed
10676 alphabetically and the canonical distroname (e.g.
10677 AUTHOR/Foo-Bar-3.14.tar.gz) is matched against the regular expressions
10678 stored in the $root->{match}{distribution} attribute value.
10679 Additionally all module names contained in a distribution are matched
10680 agains the regular expressions in the $root->{match}{module} attribute
10681 value. The two match values are ANDed together. Each of the two
10682 attributes are optional.
10683
10684 =item CPAN::Distribution::prereq_pm()
10685
10686 Returns the hash reference that has been announced by a distribution
10687 as the the C<requires> and C<build_requires> elements. These can be
10688 declared either by the C<META.yml> (if authoritative) or can be
10689 deposited after the run of C<Build.PL> in the file C<./_build/prereqs>
10690 or after the run of C<Makfile.PL> written as the C<PREREQ_PM> hash in
10691 a comment in the produced C<Makefile>. I<Note>: this method only works
10692 after an attempt has been made to C<make> the distribution. Returns
10693 undef otherwise.
10694
10695 =item CPAN::Distribution::readme()
10696
10697 Downloads the README file associated with a distribution and runs it
10698 through the pager specified in C<$CPAN::Config->{pager}>.
10699
10700 =item CPAN::Distribution::read_yaml()
10701
10702 Returns the content of the META.yml of this distro as a hashref. Note:
10703 works only after an attempt has been made to C<make> the distribution.
10704 Returns undef otherwise. Also returns undef if the content of META.yml
10705 is not authoritative. (The rules about what exactly makes the content
10706 authoritative are still in flux.)
10707
10708 =item CPAN::Distribution::test()
10709
10710 Changes to the directory where the distribution has been unpacked and
10711 runs C<make test> there.
10712
10713 =item CPAN::Distribution::uptodate()
10714
10715 Returns 1 if all the modules contained in the distribution are
10716 uptodate. Relies on containsmods.
10717
10718 =item CPAN::Index::force_reload()
10719
10720 Forces a reload of all indices.
10721
10722 =item CPAN::Index::reload()
10723
10724 Reloads all indices if they have not been read for more than
10725 C<$CPAN::Config->{index_expire}> days.
10726
10727 =item CPAN::InfoObj::dump()
10728
10729 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
10730 inherit this method. It prints the data structure associated with an
10731 object. Useful for debugging. Note: the data structure is considered
10732 internal and thus subject to change without notice.
10733
10734 =item CPAN::Module::as_glimpse()
10735
10736 Returns a one-line description of the module in four columns: The
10737 first column contains the word C<Module>, the second column consists
10738 of one character: an equals sign if this module is already installed
10739 and uptodate, a less-than sign if this module is installed but can be
10740 upgraded, and a space if the module is not installed. The third column
10741 is the name of the module and the fourth column gives maintainer or
10742 distribution information.
10743
10744 =item CPAN::Module::as_string()
10745
10746 Returns a multi-line description of the module
10747
10748 =item CPAN::Module::clean()
10749
10750 Runs a clean on the distribution associated with this module.
10751
10752 =item CPAN::Module::cpan_file()
10753
10754 Returns the filename on CPAN that is associated with the module.
10755
10756 =item CPAN::Module::cpan_version()
10757
10758 Returns the latest version of this module available on CPAN.
10759
10760 =item CPAN::Module::cvs_import()
10761
10762 Runs a cvs_import on the distribution associated with this module.
10763
10764 =item CPAN::Module::description()
10765
10766 Returns a 44 character description of this module. Only available for
10767 modules listed in The Module List (CPAN/modules/00modlist.long.html
10768 or 00modlist.long.txt.gz)
10769
10770 =item CPAN::Module::distribution()
10771
10772 Returns the CPAN::Distribution object that contains the current
10773 version of this module.
10774
10775 =item CPAN::Module::dslip_status()
10776
10777 Returns a hash reference. The keys of the hash are the letters C<D>,
10778 C<S>, C<L>, C<I>, and <P>, for development status, support level,
10779 language, interface and public licence respectively. The data for the
10780 DSLIP status are collected by pause.perl.org when authors register
10781 their namespaces. The values of the 5 hash elements are one-character
10782 words whose meaning is described in the table below. There are also 5
10783 hash elements C<DV>, C<SV>, C<LV>, C<IV>, and <PV> that carry a more
10784 verbose value of the 5 status variables.
10785
10786 Where the 'DSLIP' characters have the following meanings:
10787
10788   D - Development Stage  (Note: *NO IMPLIED TIMESCALES*):
10789     i   - Idea, listed to gain consensus or as a placeholder
10790     c   - under construction but pre-alpha (not yet released)
10791     a/b - Alpha/Beta testing
10792     R   - Released
10793     M   - Mature (no rigorous definition)
10794     S   - Standard, supplied with Perl 5
10795
10796   S - Support Level:
10797     m   - Mailing-list
10798     d   - Developer
10799     u   - Usenet newsgroup comp.lang.perl.modules
10800     n   - None known, try comp.lang.perl.modules
10801     a   - abandoned; volunteers welcome to take over maintainance
10802
10803   L - Language Used:
10804     p   - Perl-only, no compiler needed, should be platform independent
10805     c   - C and perl, a C compiler will be needed
10806     h   - Hybrid, written in perl with optional C code, no compiler needed
10807     +   - C++ and perl, a C++ compiler will be needed
10808     o   - perl and another language other than C or C++
10809
10810   I - Interface Style
10811     f   - plain Functions, no references used
10812     h   - hybrid, object and function interfaces available
10813     n   - no interface at all (huh?)
10814     r   - some use of unblessed References or ties
10815     O   - Object oriented using blessed references and/or inheritance
10816
10817   P - Public License
10818     p   - Standard-Perl: user may choose between GPL and Artistic
10819     g   - GPL: GNU General Public License
10820     l   - LGPL: "GNU Lesser General Public License" (previously known as
10821           "GNU Library General Public License")
10822     b   - BSD: The BSD License
10823     a   - Artistic license alone
10824     o   - open source: appoved by www.opensource.org
10825     d   - allows distribution without restrictions
10826     r   - restricted distribtion
10827     n   - no license at all
10828
10829 =item CPAN::Module::force($method,@args)
10830
10831 Forces CPAN to perform a task that it normally would have refused to
10832 do. Force takes as arguments a method name to be called and any number
10833 of additional arguments that should be passed to the called method.
10834 The internals of the object get the needed changes so that CPAN.pm
10835 does not refuse to take the action. See also the section above on the
10836 C<force> and the C<fforce> pragma.
10837
10838 =item CPAN::Module::get()
10839
10840 Runs a get on the distribution associated with this module.
10841
10842 =item CPAN::Module::inst_file()
10843
10844 Returns the filename of the module found in @INC. The first file found
10845 is reported just like perl itself stops searching @INC when it finds a
10846 module.
10847
10848 =item CPAN::Module::available_file()
10849
10850 Returns the filename of the module found in PERL5LIB or @INC. The
10851 first file found is reported. The advantage of this method over
10852 C<inst_file> is that modules that have been tested but not yet
10853 installed are included because PERL5LIB keeps track of tested modules.
10854
10855 =item CPAN::Module::inst_version()
10856
10857 Returns the version number of the installed module in readable format.
10858
10859 =item CPAN::Module::available_version()
10860
10861 Returns the version number of the available module in readable format.
10862
10863 =item CPAN::Module::install()
10864
10865 Runs an C<install> on the distribution associated with this module.
10866
10867 =item CPAN::Module::look()
10868
10869 Changes to the directory where the distribution associated with this
10870 module has been unpacked and opens a subshell there. Exiting the
10871 subshell returns.
10872
10873 =item CPAN::Module::make()
10874
10875 Runs a C<make> on the distribution associated with this module.
10876
10877 =item CPAN::Module::manpage_headline()
10878
10879 If module is installed, peeks into the module's manpage, reads the
10880 headline and returns it. Moreover, if the module has been downloaded
10881 within this session, does the equivalent on the downloaded module even
10882 if it is not installed.
10883
10884 =item CPAN::Module::perldoc()
10885
10886 Runs a C<perldoc> on this module.
10887
10888 =item CPAN::Module::readme()
10889
10890 Runs a C<readme> on the distribution associated with this module.
10891
10892 =item CPAN::Module::test()
10893
10894 Runs a C<test> on the distribution associated with this module.
10895
10896 =item CPAN::Module::uptodate()
10897
10898 Returns 1 if the module is installed and up-to-date.
10899
10900 =item CPAN::Module::userid()
10901
10902 Returns the author's ID of the module.
10903
10904 =back
10905
10906 =head2 Cache Manager
10907
10908 Currently the cache manager only keeps track of the build directory
10909 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
10910 deletes complete directories below C<build_dir> as soon as the size of
10911 all directories there gets bigger than $CPAN::Config->{build_cache}
10912 (in MB). The contents of this cache may be used for later
10913 re-installations that you intend to do manually, but will never be
10914 trusted by CPAN itself. This is due to the fact that the user might
10915 use these directories for building modules on different architectures.
10916
10917 There is another directory ($CPAN::Config->{keep_source_where}) where
10918 the original distribution files are kept. This directory is not
10919 covered by the cache manager and must be controlled by the user. If
10920 you choose to have the same directory as build_dir and as
10921 keep_source_where directory, then your sources will be deleted with
10922 the same fifo mechanism.
10923
10924 =head2 Bundles
10925
10926 A bundle is just a perl module in the namespace Bundle:: that does not
10927 define any functions or methods. It usually only contains documentation.
10928
10929 It starts like a perl module with a package declaration and a $VERSION
10930 variable. After that the pod section looks like any other pod with the
10931 only difference being that I<one special pod section> exists starting with
10932 (verbatim):
10933
10934         =head1 CONTENTS
10935
10936 In this pod section each line obeys the format
10937
10938         Module_Name [Version_String] [- optional text]
10939
10940 The only required part is the first field, the name of a module
10941 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
10942 of the line is optional. The comment part is delimited by a dash just
10943 as in the man page header.
10944
10945 The distribution of a bundle should follow the same convention as
10946 other distributions.
10947
10948 Bundles are treated specially in the CPAN package. If you say 'install
10949 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
10950 the modules in the CONTENTS section of the pod. You can install your
10951 own Bundles locally by placing a conformant Bundle file somewhere into
10952 your @INC path. The autobundle() command which is available in the
10953 shell interface does that for you by including all currently installed
10954 modules in a snapshot bundle file.
10955
10956 =head1 PREREQUISITES
10957
10958 If you have a local mirror of CPAN and can access all files with
10959 "file:" URLs, then you only need a perl better than perl5.003 to run
10960 this module. Otherwise Net::FTP is strongly recommended. LWP may be
10961 required for non-UNIX systems or if your nearest CPAN site is
10962 associated with a URL that is not C<ftp:>.
10963
10964 If you have neither Net::FTP nor LWP, there is a fallback mechanism
10965 implemented for an external ftp command or for an external lynx
10966 command.
10967
10968 =head1 UTILITIES
10969
10970 =head2 Finding packages and VERSION
10971
10972 This module presumes that all packages on CPAN
10973
10974 =over 2
10975
10976 =item *
10977
10978 declare their $VERSION variable in an easy to parse manner. This
10979 prerequisite can hardly be relaxed because it consumes far too much
10980 memory to load all packages into the running program just to determine
10981 the $VERSION variable. Currently all programs that are dealing with
10982 version use something like this
10983
10984     perl -MExtUtils::MakeMaker -le \
10985         'print MM->parse_version(shift)' filename
10986
10987 If you are author of a package and wonder if your $VERSION can be
10988 parsed, please try the above method.
10989
10990 =item *
10991
10992 come as compressed or gzipped tarfiles or as zip files and contain a
10993 C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
10994 without much enthusiasm).
10995
10996 =back
10997
10998 =head2 Debugging
10999
11000 The debugging of this module is a bit complex, because we have
11001 interferences of the software producing the indices on CPAN, of the
11002 mirroring process on CPAN, of packaging, of configuration, of
11003 synchronicity, and of bugs within CPAN.pm.
11004
11005 For debugging the code of CPAN.pm itself in interactive mode some more
11006 or less useful debugging aid can be turned on for most packages within
11007 CPAN.pm with one of
11008
11009 =over 2
11010
11011 =item o debug package...
11012
11013 sets debug mode for packages.
11014
11015 =item o debug -package...
11016
11017 unsets debug mode for packages.
11018
11019 =item o debug all
11020
11021 turns debugging on for all packages.
11022
11023 =item o debug number
11024
11025 =back
11026
11027 which sets the debugging packages directly. Note that C<o debug 0>
11028 turns debugging off.
11029
11030 What seems quite a successful strategy is the combination of C<reload
11031 cpan> and the debugging switches. Add a new debug statement while
11032 running in the shell and then issue a C<reload cpan> and see the new
11033 debugging messages immediately without losing the current context.
11034
11035 C<o debug> without an argument lists the valid package names and the
11036 current set of packages in debugging mode. C<o debug> has built-in
11037 completion support.
11038
11039 For debugging of CPAN data there is the C<dump> command which takes
11040 the same arguments as make/test/install and outputs each object's
11041 Data::Dumper dump. If an argument looks like a perl variable and
11042 contains one of C<$>, C<@> or C<%>, it is eval()ed and fed to
11043 Data::Dumper directly.
11044
11045 =head2 Floppy, Zip, Offline Mode
11046
11047 CPAN.pm works nicely without network too. If you maintain machines
11048 that are not networked at all, you should consider working with file:
11049 URLs. Of course, you have to collect your modules somewhere first. So
11050 you might use CPAN.pm to put together all you need on a networked
11051 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
11052 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
11053 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
11054 with this floppy. See also below the paragraph about CD-ROM support.
11055
11056 =head2 Basic Utilities for Programmers
11057
11058 =over 2
11059
11060 =item has_inst($module)
11061
11062 Returns true if the module is installed. Used to load all modules into
11063 the running CPAN.pm which are considered optional. The config variable
11064 C<dontload_list> can be used to intercept the C<has_inst()> call such
11065 that an optional module is not loaded despite being available. For
11066 example the following command will prevent that C<YAML.pm> is being
11067 loaded:
11068
11069     cpan> o conf dontload_list push YAML
11070
11071 See the source for details.
11072
11073 =item has_usable($module)
11074
11075 Returns true if the module is installed and is in a usable state. Only
11076 useful for a handful of modules that are used internally. See the
11077 source for details.
11078
11079 =item instance($module)
11080
11081 The constructor for all the singletons used to represent modules,
11082 distributions, authors and bundles. If the object already exists, this
11083 method returns the object, otherwise it calls the constructor.
11084
11085 =back
11086
11087 =head1 SECURITY
11088
11089 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
11090 install foreign, unmasked, unsigned code on your machine. We compare
11091 to a checksum that comes from the net just as the distribution file
11092 itself. But we try to make it easy to add security on demand:
11093
11094 =head2 Cryptographically signed modules
11095
11096 Since release 1.77 CPAN.pm has been able to verify cryptographically
11097 signed module distributions using Module::Signature.  The CPAN modules
11098 can be signed by their authors, thus giving more security.  The simple
11099 unsigned MD5 checksums that were used before by CPAN protect mainly
11100 against accidental file corruption.
11101
11102 You will need to have Module::Signature installed, which in turn
11103 requires that you have at least one of Crypt::OpenPGP module or the
11104 command-line F<gpg> tool installed.
11105
11106 You will also need to be able to connect over the Internet to the public
11107 keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
11108
11109 The configuration parameter check_sigs is there to turn signature
11110 checking on or off.
11111
11112 =head1 EXPORT
11113
11114 Most functions in package CPAN are exported per default. The reason
11115 for this is that the primary use is intended for the cpan shell or for
11116 one-liners.
11117
11118 =head1 ENVIRONMENT
11119
11120 When the CPAN shell enters a subshell via the look command, it sets
11121 the environment CPAN_SHELL_LEVEL to 1 or increments it if it is
11122 already set.
11123
11124 When CPAN runs, it sets the environment variable PERL5_CPAN_IS_RUNNING.
11125
11126 When the config variable ftp_passive is set, all downloads will be run
11127 with the environment variable FTP_PASSIVE set to this value. This is
11128 in general a good idea as it influences both Net::FTP and LWP based
11129 connections. The same effect can be achieved by starting the cpan
11130 shell with this environment variable set. For Net::FTP alone, one can
11131 also always set passive mode by running libnetcfg.
11132
11133 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
11134
11135 Populating a freshly installed perl with my favorite modules is pretty
11136 easy if you maintain a private bundle definition file. To get a useful
11137 blueprint of a bundle definition file, the command autobundle can be used
11138 on the CPAN shell command line. This command writes a bundle definition
11139 file for all modules that are installed for the currently running perl
11140 interpreter. It's recommended to run this command only once and from then
11141 on maintain the file manually under a private name, say
11142 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
11143
11144     cpan> install Bundle::my_bundle
11145
11146 then answer a few questions and then go out for a coffee.
11147
11148 Maintaining a bundle definition file means keeping track of two
11149 things: dependencies and interactivity. CPAN.pm sometimes fails on
11150 calculating dependencies because not all modules define all MakeMaker
11151 attributes correctly, so a bundle definition file should specify
11152 prerequisites as early as possible. On the other hand, it's a bit
11153 annoying that many distributions need some interactive configuring. So
11154 what I try to accomplish in my private bundle file is to have the
11155 packages that need to be configured early in the file and the gentle
11156 ones later, so I can go out after a few minutes and leave CPAN.pm
11157 untended.
11158
11159 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
11160
11161 Thanks to Graham Barr for contributing the following paragraphs about
11162 the interaction between perl, and various firewall configurations. For
11163 further information on firewalls, it is recommended to consult the
11164 documentation that comes with the ncftp program. If you are unable to
11165 go through the firewall with a simple Perl setup, it is very likely
11166 that you can configure ncftp so that it works for your firewall.
11167
11168 =head2 Three basic types of firewalls
11169
11170 Firewalls can be categorized into three basic types.
11171
11172 =over 4
11173
11174 =item http firewall
11175
11176 This is where the firewall machine runs a web server and to access the
11177 outside world you must do it via the web server. If you set environment
11178 variables like http_proxy or ftp_proxy to a values beginning with http://
11179 or in your web browser you have to set proxy information then you know
11180 you are running an http firewall.
11181
11182 To access servers outside these types of firewalls with perl (even for
11183 ftp) you will need to use LWP.
11184
11185 =item ftp firewall
11186
11187 This where the firewall machine runs an ftp server. This kind of
11188 firewall will only let you access ftp servers outside the firewall.
11189 This is usually done by connecting to the firewall with ftp, then
11190 entering a username like "user@outside.host.com"
11191
11192 To access servers outside these type of firewalls with perl you
11193 will need to use Net::FTP.
11194
11195 =item One way visibility
11196
11197 I say one way visibility as these firewalls try to make themselves look
11198 invisible to the users inside the firewall. An FTP data connection is
11199 normally created by sending the remote server your IP address and then
11200 listening for the connection. But the remote server will not be able to
11201 connect to you because of the firewall. So for these types of firewall
11202 FTP connections need to be done in a passive mode.
11203
11204 There are two that I can think off.
11205
11206 =over 4
11207
11208 =item SOCKS
11209
11210 If you are using a SOCKS firewall you will need to compile perl and link
11211 it with the SOCKS library, this is what is normally called a 'socksified'
11212 perl. With this executable you will be able to connect to servers outside
11213 the firewall as if it is not there.
11214
11215 =item IP Masquerade
11216
11217 This is the firewall implemented in the Linux kernel, it allows you to
11218 hide a complete network behind one IP address. With this firewall no
11219 special compiling is needed as you can access hosts directly.
11220
11221 For accessing ftp servers behind such firewalls you usually need to
11222 set the environment variable C<FTP_PASSIVE> or the config variable
11223 ftp_passive to a true value.
11224
11225 =back
11226
11227 =back
11228
11229 =head2 Configuring lynx or ncftp for going through a firewall
11230
11231 If you can go through your firewall with e.g. lynx, presumably with a
11232 command such as
11233
11234     /usr/local/bin/lynx -pscott:tiger
11235
11236 then you would configure CPAN.pm with the command
11237
11238     o conf lynx "/usr/local/bin/lynx -pscott:tiger"
11239
11240 That's all. Similarly for ncftp or ftp, you would configure something
11241 like
11242
11243     o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
11244
11245 Your mileage may vary...
11246
11247 =head1 FAQ
11248
11249 =over 4
11250
11251 =item 1)
11252
11253 I installed a new version of module X but CPAN keeps saying,
11254 I have the old version installed
11255
11256 Most probably you B<do> have the old version installed. This can
11257 happen if a module installs itself into a different directory in the
11258 @INC path than it was previously installed. This is not really a
11259 CPAN.pm problem, you would have the same problem when installing the
11260 module manually. The easiest way to prevent this behaviour is to add
11261 the argument C<UNINST=1> to the C<make install> call, and that is why
11262 many people add this argument permanently by configuring
11263
11264   o conf make_install_arg UNINST=1
11265
11266 =item 2)
11267
11268 So why is UNINST=1 not the default?
11269
11270 Because there are people who have their precise expectations about who
11271 may install where in the @INC path and who uses which @INC array. In
11272 fine tuned environments C<UNINST=1> can cause damage.
11273
11274 =item 3)
11275
11276 I want to clean up my mess, and install a new perl along with
11277 all modules I have. How do I go about it?
11278
11279 Run the autobundle command for your old perl and optionally rename the
11280 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
11281 with the Configure option prefix, e.g.
11282
11283     ./Configure -Dprefix=/usr/local/perl-5.6.78.9
11284
11285 Install the bundle file you produced in the first step with something like
11286
11287     cpan> install Bundle::mybundle
11288
11289 and you're done.
11290
11291 =item 4)
11292
11293 When I install bundles or multiple modules with one command
11294 there is too much output to keep track of.
11295
11296 You may want to configure something like
11297
11298   o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
11299   o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
11300
11301 so that STDOUT is captured in a file for later inspection.
11302
11303
11304 =item 5)
11305
11306 I am not root, how can I install a module in a personal directory?
11307
11308 First of all, you will want to use your own configuration, not the one
11309 that your root user installed. If you do not have permission to write
11310 in the cpan directory that root has configured, you will be asked if
11311 you want to create your own config. Answering "yes" will bring you into
11312 CPAN's configuration stage, using the system config for all defaults except
11313 things that have to do with CPAN's work directory, saving your choices to
11314 your MyConfig.pm file.
11315
11316 You can also manually initiate this process with the following command:
11317
11318     % perl -MCPAN -e 'mkmyconfig'
11319
11320 or by running
11321
11322     mkmyconfig
11323
11324 from the CPAN shell.
11325
11326 You will most probably also want to configure something like this:
11327
11328   o conf makepl_arg "LIB=~/myperl/lib \
11329                     INSTALLMAN1DIR=~/myperl/man/man1 \
11330                     INSTALLMAN3DIR=~/myperl/man/man3"
11331
11332 You can make this setting permanent like all C<o conf> settings with
11333 C<o conf commit>.
11334
11335 You will have to add ~/myperl/man to the MANPATH environment variable
11336 and also tell your perl programs to look into ~/myperl/lib, e.g. by
11337 including
11338
11339   use lib "$ENV{HOME}/myperl/lib";
11340
11341 or setting the PERL5LIB environment variable.
11342
11343 While we're speaking about $ENV{HOME}, it might be worth mentioning,
11344 that for Windows we use the File::HomeDir module that provides an
11345 equivalent to the concept of the home directory on Unix.
11346
11347 Another thing you should bear in mind is that the UNINST parameter can
11348 be dnagerous when you are installing into a private area because you
11349 might accidentally remove modules that other people depend on that are
11350 not using the private area.
11351
11352 =item 6)
11353
11354 How to get a package, unwrap it, and make a change before building it?
11355
11356 Have a look at the C<look> (!) command.
11357
11358 =item 7)
11359
11360 I installed a Bundle and had a couple of fails. When I
11361 retried, everything resolved nicely. Can this be fixed to work
11362 on first try?
11363
11364 The reason for this is that CPAN does not know the dependencies of all
11365 modules when it starts out. To decide about the additional items to
11366 install, it just uses data found in the META.yml file or the generated
11367 Makefile. An undetected missing piece breaks the process. But it may
11368 well be that your Bundle installs some prerequisite later than some
11369 depending item and thus your second try is able to resolve everything.
11370 Please note, CPAN.pm does not know the dependency tree in advance and
11371 cannot sort the queue of things to install in a topologically correct
11372 order. It resolves perfectly well IF all modules declare the
11373 prerequisites correctly with the PREREQ_PM attribute to MakeMaker or
11374 the C<requires> stanza of Module::Build. For bundles which fail and
11375 you need to install often, it is recommended to sort the Bundle
11376 definition file manually.
11377
11378 =item 8)
11379
11380 In our intranet we have many modules for internal use. How
11381 can I integrate these modules with CPAN.pm but without uploading
11382 the modules to CPAN?
11383
11384 Have a look at the CPAN::Site module.
11385
11386 =item 9)
11387
11388 When I run CPAN's shell, I get an error message about things in my
11389 /etc/inputrc (or ~/.inputrc) file.
11390
11391 These are readline issues and can only be fixed by studying readline
11392 configuration on your architecture and adjusting the referenced file
11393 accordingly. Please make a backup of the /etc/inputrc or ~/.inputrc
11394 and edit them. Quite often harmless changes like uppercasing or
11395 lowercasing some arguments solves the problem.
11396
11397 =item 10)
11398
11399 Some authors have strange characters in their names.
11400
11401 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
11402 expecting ISO-8859-1 charset, a converter can be activated by setting
11403 term_is_latin to a true value in your config file. One way of doing so
11404 would be
11405
11406     cpan> o conf term_is_latin 1
11407
11408 If other charset support is needed, please file a bugreport against
11409 CPAN.pm at rt.cpan.org and describe your needs. Maybe we can extend
11410 the support or maybe UTF-8 terminals become widely available.
11411
11412 =item 11)
11413
11414 When an install fails for some reason and then I correct the error
11415 condition and retry, CPAN.pm refuses to install the module, saying
11416 C<Already tried without success>.
11417
11418 Use the force pragma like so
11419
11420   force install Foo::Bar
11421
11422 Or you can use
11423
11424   look Foo::Bar
11425
11426 and then 'make install' directly in the subshell.
11427
11428 =item 12)
11429
11430 How do I install a "DEVELOPER RELEASE" of a module?
11431
11432 By default, CPAN will install the latest non-developer release of a
11433 module. If you want to install a dev release, you have to specify the
11434 partial path starting with the author id to the tarball you wish to
11435 install, like so:
11436
11437     cpan> install KWILLIAMS/Module-Build-0.27_07.tar.gz
11438
11439 Note that you can use the C<ls> command to get this path listed.
11440
11441 =item 13)
11442
11443 How do I install a module and all its dependencies from the commandline,
11444 without being prompted for anything, despite my CPAN configuration
11445 (or lack thereof)?
11446
11447 CPAN uses ExtUtils::MakeMaker's prompt() function to ask its questions, so
11448 if you set the PERL_MM_USE_DEFAULT environment variable, you shouldn't be
11449 asked any questions at all (assuming the modules you are installing are
11450 nice about obeying that variable as well):
11451
11452     % PERL_MM_USE_DEFAULT=1 perl -MCPAN -e 'install My::Module'
11453
11454 =item 14)
11455
11456 How do I create a Module::Build based Build.PL derived from an
11457 ExtUtils::MakeMaker focused Makefile.PL?
11458
11459 http://search.cpan.org/search?query=Module::Build::Convert
11460
11461 http://accognoscere.org/papers/perl-module-build-convert/module-build-convert.html
11462
11463 =item 15)
11464
11465 What's the best CPAN site for me?
11466
11467 The urllist config parameter is yours. You can add and remove sites at
11468 will. You should find out which sites have the best uptodateness,
11469 bandwidth, reliability, etc. and are topologically close to you. Some
11470 people prefer fast downloads, others uptodateness, others reliability.
11471 You decide which to try in which order.
11472
11473 Henk P. Penning maintains a site that collects data about CPAN sites:
11474
11475   http://www.cs.uu.nl/people/henkp/mirmon/cpan.html
11476
11477 =back
11478
11479 =head1 COMPATIBILITY
11480
11481 =head2 OLD PERL VERSIONS
11482
11483 CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted
11484 newer versions. It is getting more and more difficult to get the
11485 minimal prerequisites working on older perls. It is close to
11486 impossible to get the whole Bundle::CPAN working there. If you're in
11487 the position to have only these old versions, be advised that CPAN is
11488 designed to work fine without the Bundle::CPAN installed.
11489
11490 To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is
11491 compatible with ancient perls and that File::Temp is listed as a
11492 prerequisite but CPAN has reasonable workarounds if it is missing.
11493
11494 =head2 CPANPLUS
11495
11496 This module and its competitor, the CPANPLUS module, are both much
11497 cooler than the other. CPAN.pm is older. CPANPLUS was designed to be
11498 more modular but it was never tried to make it compatible with CPAN.pm.
11499
11500 =head1 SECURITY ADVICE
11501
11502 This software enables you to upgrade software on your computer and so
11503 is inherently dangerous because the newly installed software may
11504 contain bugs and may alter the way your computer works or even make it
11505 unusable. Please consider backing up your data before every upgrade.
11506
11507 =head1 BUGS
11508
11509 Please report bugs via http://rt.cpan.org/
11510
11511 Before submitting a bug, please make sure that the traditional method
11512 of building a Perl module package from a shell by following the
11513 installation instructions of that package still works in your
11514 environment.
11515
11516 =head1 AUTHOR
11517
11518 Andreas Koenig C<< <andk@cpan.org> >>
11519
11520 =head1 LICENSE
11521
11522 This program is free software; you can redistribute it and/or
11523 modify it under the same terms as Perl itself.
11524
11525 See L<http://www.perl.com/perl/misc/Artistic.html>
11526
11527 =head1 TRANSLATIONS
11528
11529 Kawai,Takanori provides a Japanese translation of this manpage at
11530 http://homepage3.nifty.com/hippo2000/perltips/CPAN.htm
11531
11532 =head1 SEE ALSO
11533
11534 cpan(1), CPAN::Nox(3pm), CPAN::Version(3pm)
11535
11536 =cut
11537
11538