lib/CPAN.pm

   1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
   2 use strict;
   3 package CPAN;
   4 $CPAN::VERSION = '1.88_66';
   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             $DEBUG
  68             $Defaultdocs
  69             $Defaultrecent
  70             $Frontend
  71             $GOTOSHELL
  72             $HAS_USABLE
  73             $Have_warned
  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 @CPAN::ISA = qw(CPAN::Debug Exporter);
  87
  88 # note that these functions live in CPAN::Shell and get executed via
  89 # AUTOLOAD when called directly
  90 @EXPORT = qw(
  91              autobundle
  92              bundle
  93              clean
  94              cvs_import
  95              expand
  96              force
  97              get
  98              install
  99              install_tested
 100              make
 101              mkmyconfig
 102              notest
 103              perldoc
 104              readme
 105              recent
 106              recompile
 107              report
 108              shell
 109              test
 110              upgrade
 111             );
 112
 113 sub soft_chdir_with_alternatives ($);
 114
 115 {
 116     $autoload_recursion ||= 0;
 117
 118     #-> sub CPAN::AUTOLOAD ;
 119     sub AUTOLOAD {
 120         $autoload_recursion++;
 121         my($l) = $AUTOLOAD;
 122         $l =~ s/.*:://;
 123         if ($CPAN::Signal) {
 124             warn "Refusing to autoload '$l' while signal pending";
 125             $autoload_recursion--;
 126             return;
 127         }
 128         if ($autoload_recursion > 1) {
 129             my $fullcommand = join " ", map { "'$_'" } $l, @_;
 130             warn "Refusing to autoload $fullcommand in recursion\n";
 131             $autoload_recursion--;
 132             return;
 133         }
 134         my(%export);
 135         @export{@EXPORT} = '';
 136         CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 137         if (exists $export{$l}){
 138             CPAN::Shell->$l(@_);
 139         } else {
 140             die(qq{Unknown CPAN command "$AUTOLOAD". }.
 141                 qq{Type ? for help.\n});
 142         }
 143         $autoload_recursion--;
 144     }
 145 }
 146
 147 #-> sub CPAN::shell ;
 148 sub shell {
 149     my($self) = @_;
 150     $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
 151     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 152
 153     my $oprompt = shift || CPAN::Prompt->new;
 154     my $prompt = $oprompt;
 155     my $commandline = shift || "";
 156     $CPAN::CurrentCommandId ||= 1;
 157
 158     local($^W) = 1;
 159     unless ($Suppress_readline) {
 160         require Term::ReadLine;
 161         if (! $term
 162             or
 163             $term->ReadLine eq "Term::ReadLine::Stub"
 164            ) {
 165             $term = Term::ReadLine->new('CPAN Monitor');
 166         }
 167         if ($term->ReadLine eq "Term::ReadLine::Gnu") {
 168             my $attribs = $term->Attribs;
 169              $attribs->{attempted_completion_function} = sub {
 170                  &CPAN::Complete::gnu_cpl;
 171              }
 172         } else {
 173             $readline::rl_completion_function =
 174                 $readline::rl_completion_function = 'CPAN::Complete::cpl';
 175         }
 176         if (my $histfile = $CPAN::Config->{'histfile'}) {{
 177             unless ($term->can("AddHistory")) {
 178                 $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
 179                 last;
 180             }
 181             my($fh) = FileHandle->new;
 182             open $fh, "<$histfile" or last;
 183             local $/ = "\n";
 184             while (<$fh>) {
 185                 chomp;
 186                 $term->AddHistory($_);
 187             }
 188             close $fh;
 189         }}
 190         for ($CPAN::Config->{term_ornaments}) { # alias
 191             local $Term::ReadLine::termcap_nowarn = 1;
 192             $term->ornaments($_) if defined;
 193         }
 194         # $term->OUT is autoflushed anyway
 195         my $odef = select STDERR;
 196         $| = 1;
 197         select STDOUT;
 198         $| = 1;
 199         select $odef;
 200     }
 201
 202     $META->checklock();
 203     my @cwd = grep { defined $_ and length $_ }
 204         CPAN::anycwd(),
 205               File::Spec->can("tmpdir") ? File::Spec->tmpdir() : (),
 206                     File::Spec->rootdir();
 207     my $try_detect_readline;
 208     $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
 209     my $rl_avail = $Suppress_readline ? "suppressed" :
 210         ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
 211             "available (try 'install Bundle::CPAN')";
 212
 213     unless ($CPAN::Config->{'inhibit_startup_message'}){
 214         $CPAN::Frontend->myprint(
 215                                  sprintf qq{
 216 cpan shell -- CPAN exploration and modules installation (v%s)
 217 ReadLine support %s
 218
 219 },
 220                                  $CPAN::VERSION,
 221                                  $rl_avail
 222                                 )
 223     }
 224     my($continuation) = "";
 225     my $last_term_ornaments;
 226   SHELLCOMMAND: while () {
 227         if ($Suppress_readline) {
 228             print $prompt;
 229             last SHELLCOMMAND unless defined ($_ = <> );
 230             chomp;
 231         } else {
 232             last SHELLCOMMAND unless
 233                 defined ($_ = $term->readline($prompt, $commandline));
 234         }
 235         $_ = "$continuation$_" if $continuation;
 236         s/^\s+//;
 237         next SHELLCOMMAND if /^$/;
 238         $_ = 'h' if /^\s*\?/;
 239         if (/^(?:q(?:uit)?|bye|exit)$/i) {
 240             last SHELLCOMMAND;
 241         } elsif (s/\\$//s) {
 242             chomp;
 243             $continuation = $_;
 244             $prompt = "    > ";
 245         } elsif (/^\!/) {
 246             s/^\!//;
 247             my($eval) = $_;
 248             package CPAN::Eval;
 249             use strict;
 250             use vars qw($import_done);
 251             CPAN->import(':DEFAULT') unless $import_done++;
 252             CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
 253             eval($eval);
 254             warn $@ if $@;
 255             $continuation = "";
 256             $prompt = $oprompt;
 257         } elsif (/./) {
 258             my(@line);
 259             eval { @line = Text::ParseWords::shellwords($_) };
 260             warn($@), next SHELLCOMMAND if $@;
 261             warn("Text::Parsewords could not parse the line [$_]"),
 262                 next SHELLCOMMAND unless @line;
 263             $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
 264             my $command = shift @line;
 265             eval { CPAN::Shell->$command(@line) };
 266             if ($@){
 267                 require Carp;
 268                 Carp::cluck($@);
 269             }
 270             if ($command =~ /^(make|test|install|ff?orce|notest|clean|report|upgrade)$/) {
 271                 CPAN::Shell->failed($CPAN::CurrentCommandId,1);
 272             }
 273             soft_chdir_with_alternatives(\@cwd);
 274             $CPAN::Frontend->myprint("\n");
 275             $continuation = "";
 276             $CPAN::CurrentCommandId++;
 277             $prompt = $oprompt;
 278         }
 279     } continue {
 280       $commandline = ""; # I do want to be able to pass a default to
 281                          # shell, but on the second command I see no
 282                          # use in that
 283       $Signal=0;
 284       CPAN::Queue->nullify_queue;
 285       if ($try_detect_readline) {
 286         if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
 287             ||
 288             $CPAN::META->has_inst("Term::ReadLine::Perl")
 289            ) {
 290             delete $INC{"Term/ReadLine.pm"};
 291             my $redef = 0;
 292             local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
 293             require Term::ReadLine;
 294             $CPAN::Frontend->myprint("\n$redef subroutines in ".
 295                                      "Term::ReadLine redefined\n");
 296             $GOTOSHELL = 1;
 297         }
 298       }
 299       if ($term and $term->can("ornaments")) {
 300           for ($CPAN::Config->{term_ornaments}) { # alias
 301               if (defined $_) {
 302                   if (not defined $last_term_ornaments
 303                       or $_ != $last_term_ornaments
 304                      ) {
 305                       local $Term::ReadLine::termcap_nowarn = 1;
 306                       $term->ornaments($_);
 307                       $last_term_ornaments = $_;
 308                   }
 309               } else {
 310                   undef $last_term_ornaments;
 311               }
 312           }
 313       }
 314       for my $class (qw(Module Distribution)) {
 315           # again unsafe meta access?
 316           for my $dm (keys %{$CPAN::META->{readwrite}{"CPAN::$class"}}) {
 317               next unless $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
 318               CPAN->debug("BUG: $class '$dm' was in command state, resetting");
 319               delete $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
 320           }
 321       }
 322       if ($GOTOSHELL) {
 323           $GOTOSHELL = 0; # not too often
 324           $META->savehist if $CPAN::term && $CPAN::term->can("GetHistory");
 325           @_ = ($oprompt,"");
 326           goto &shell;
 327       }
 328     }
 329     soft_chdir_with_alternatives(\@cwd);
 330 }
 331
 332 sub soft_chdir_with_alternatives ($) {
 333     my($cwd) = @_;
 334     unless (@$cwd) {
 335         my $root = File::Spec->rootdir();
 336         $CPAN::Frontend->mywarn(qq{Warning: no good directory to chdir to!
 337 Trying '$root' as temporary haven.
 338 });
 339         push @$cwd, $root;
 340     }
 341     while () {
 342         if (chdir $cwd->[0]) {
 343             return;
 344         } else {
 345             if (@$cwd>1) {
 346                 $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $!
 347 Trying to chdir to "$cwd->[1]" instead.
 348 });
 349                 shift @$cwd;
 350             } else {
 351                 $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!});
 352             }
 353         }
 354     }
 355 }
 356
 357 sub _yaml_module {
 358     my $yaml_module = $CPAN::Config->{yaml_module} || "YAML";
 359     if (
 360         $yaml_module ne "YAML"
 361         &&
 362         !$CPAN::META->has_inst($yaml_module)
 363        ) {
 364         # $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back to 'YAML'\n");
 365         $yaml_module = "YAML";
 366     }
 367     return $yaml_module;
 368 }
 369
 370 # CPAN::_yaml_loadfile
 371 sub _yaml_loadfile {
 372     my($self,$local_file) = @_;
 373     return +[] unless -s $local_file;
 374     my $yaml_module = $self->_yaml_module;
 375     if ($CPAN::META->has_inst($yaml_module)) {
 376         my $code = UNIVERSAL::can($yaml_module, "LoadFile");
 377         my @yaml;
 378         eval { @yaml = $code->($local_file); };
 379         if ($@) {
 380             $CPAN::Frontend->mydie("Alert: While trying to parse YAML file\n".
 381                                    "  $local_file\n".
 382                                    "with $yaml_module the following error was encountered:\n".
 383                                    "  $@\n"
 384                                   );
 385         }
 386         return \@yaml;
 387     } else {
 388         $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot parse '$local_file'\n");
 389     }
 390     return +[];
 391 }
 392
 393 # CPAN::_yaml_dumpfile
 394 sub _yaml_dumpfile {
 395     my($self,$to_local_file,@what) = @_;
 396     my $yaml_module = $self->_yaml_module;
 397     if ($CPAN::META->has_inst($yaml_module)) {
 398         if (UNIVERSAL::isa($to_local_file, "FileHandle")) {
 399             my $code = UNIVERSAL::can($yaml_module, "Dump");
 400             eval { print $to_local_file $code->(@what) };
 401         } else {
 402             my $code = UNIVERSAL::can($yaml_module, "DumpFile");
 403             eval { $code->($to_local_file,@what); };
 404         }
 405         if ($@) {
 406             $CPAN::Frontend->mydie("Alert: While trying to dump YAML file\n".
 407                                    "  $to_local_file\n".
 408                                    "with $yaml_module the following error was encountered:\n".
 409                                    "  $@\n"
 410                                   );
 411         }
 412     } else {
 413         if (UNIVERSAL::isa($to_local_file, "FileHandle")) {
 414             # I think this case does not justify a warning at all
 415         } else {
 416             $CPAN::Frontend->myprint("Note (usually harmless): '$yaml_module' ".
 417                                      "not installed, not dumping to '$to_local_file'\n");
 418         }
 419     }
 420 }
 421
 422 sub _init_sqlite () {
 423     unless ($CPAN::META->has_inst("CPAN::SQLite")) {
 424         $CPAN::Frontend->mywarn(qq{CPAN::SQLite not installed, cannot work with it\n})
 425             unless $Have_warned->{"CPAN::SQLite"}++;
 426         return;
 427     }
 428     require CPAN::SQLite::META; # not needed since CVS version of 2006-12-17
 429     $CPAN::SQLite ||= CPAN::SQLite::META->new($CPAN::META);
 430 }
 431
 432 {
 433     my $negative_cache = {};
 434     sub _sqlite_running {
 435         if ($negative_cache->{time} && time < $negative_cache->{time} + 60) {
 436             # need to cache the result, otherwise too slow
 437             return $negative_cache->{fact};
 438         } else {
 439             $negative_cache = {}; # reset
 440         }
 441         my $ret = $CPAN::Config->{use_sqlite} && ($CPAN::SQLite || _init_sqlite());
 442         return $ret if $ret; # fast anyway
 443         $negative_cache->{time} = time;
 444         return $negative_cache->{fact} = $ret;
 445     }
 446 }
 447
 448 package CPAN::CacheMgr;
 449 use strict;
 450 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
 451 use File::Find;
 452
 453 package CPAN::FTP;
 454 use strict;
 455 use Fcntl qw(:flock);
 456 use vars qw($Ua $Thesite $ThesiteURL $Themethod);
 457 @CPAN::FTP::ISA = qw(CPAN::Debug);
 458
 459 package CPAN::LWP::UserAgent;
 460 use strict;
 461 use vars qw(@ISA $USER $PASSWD $SETUPDONE);
 462 # we delay requiring LWP::UserAgent and setting up inheritance until we need it
 463
 464 package CPAN::Complete;
 465 use strict;
 466 @CPAN::Complete::ISA = qw(CPAN::Debug);
 467 # Q: where is the "How do I add a new command" HOWTO?
 468 # A: svn diff -r 1048:1049 where andk added the report command
 469 @CPAN::Complete::COMMANDS = sort qw(
 470                                     ! a b d h i m o q r u
 471                                     autobundle
 472                                     clean
 473                                     cvs_import
 474                                     dump
 475                                     force
 476                                     hosts
 477                                     install
 478                                     install_tested
 479                                     look
 480                                     ls
 481                                     make
 482                                     mkmyconfig
 483                                     notest
 484                                     perldoc
 485                                     readme
 486                                     recent
 487                                     recompile
 488                                     reload
 489                                     report
 490                                     scripts
 491                                     test
 492                                     upgrade
 493 );
 494
 495 package CPAN::Index;
 496 use strict;
 497 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED);
 498 @CPAN::Index::ISA = qw(CPAN::Debug);
 499 $LAST_TIME ||= 0;
 500 $DATE_OF_03 ||= 0;
 501 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
 502 sub PROTOCOL { 2.0 }
 503
 504 package CPAN::InfoObj;
 505 use strict;
 506 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
 507
 508 package CPAN::Author;
 509 use strict;
 510 @CPAN::Author::ISA = qw(CPAN::InfoObj);
 511
 512 package CPAN::Distribution;
 513 use strict;
 514 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
 515
 516 package CPAN::Bundle;
 517 use strict;
 518 @CPAN::Bundle::ISA = qw(CPAN::Module);
 519
 520 package CPAN::Module;
 521 use strict;
 522 @CPAN::Module::ISA = qw(CPAN::InfoObj);
 523
 524 package CPAN::Exception::RecursiveDependency;
 525 use strict;
 526 use overload '""' => "as_string";
 527
 528 sub new {
 529     my($class) = shift;
 530     my($deps) = shift;
 531     my @deps;
 532     my %seen;
 533     for my $dep (@$deps) {
 534         push @deps, $dep;
 535         last if $seen{$dep}++;
 536     }
 537     bless { deps => \@deps }, $class;
 538 }
 539
 540 sub as_string {
 541     my($self) = shift;
 542     "\nRecursive dependency detected:\n    " .
 543         join("\n => ", @{$self->{deps}}) .
 544             ".\nCannot continue.\n";
 545 }
 546
 547 package CPAN::Prompt; use overload '""' => "as_string";
 548 use vars qw($prompt);
 549 $prompt = "cpan> ";
 550 $CPAN::CurrentCommandId ||= 0;
 551 sub new {
 552     bless {}, shift;
 553 }
 554 sub as_string {
 555     my $word = "cpan";
 556     unless ($CPAN::META->{LOCK}) {
 557         $word = "nolock_cpan";
 558     }
 559     if ($CPAN::Config->{commandnumber_in_prompt}) {
 560         sprintf "$word\[%d]> ", $CPAN::CurrentCommandId;
 561     } else {
 562         "$word> ";
 563     }
 564 }
 565
 566 package CPAN::URL; use overload '""' => "as_string", fallback => 1;
 567 # accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist),
 568 # planned are things like age or quality
 569 sub new {
 570     my($class,%args) = @_;
 571     bless {
 572            %args
 573           }, $class;
 574 }
 575 sub as_string {
 576     my($self) = @_;
 577     $self->text;
 578 }
 579 sub text {
 580     my($self,$set) = @_;
 581     if (defined $set) {
 582         $self->{TEXT} = $set;
 583     }
 584     $self->{TEXT};
 585 }
 586
 587 package CPAN::Distrostatus;
 588 use overload '""' => "as_string",
 589     fallback => 1;
 590 sub new {
 591     my($class,$arg) = @_;
 592     bless {
 593            TEXT => $arg,
 594            FAILED => substr($arg,0,2) eq "NO",
 595            COMMANDID => $CPAN::CurrentCommandId,
 596            TIME => time,
 597           }, $class;
 598 }
 599 sub commandid { shift->{COMMANDID} }
 600 sub failed { shift->{FAILED} }
 601 sub text {
 602     my($self,$set) = @_;
 603     if (defined $set) {
 604         $self->{TEXT} = $set;
 605     }
 606     $self->{TEXT};
 607 }
 608 sub as_string {
 609     my($self) = @_;
 610     $self->text;
 611 }
 612
 613 package CPAN::Shell;
 614 use strict;
 615 use vars qw(
 616             $ADVANCED_QUERY
 617             $AUTOLOAD
 618             $COLOR_REGISTERED
 619             $autoload_recursion
 620             $reload
 621             @ISA
 622            );
 623 @CPAN::Shell::ISA = qw(CPAN::Debug);
 624 $COLOR_REGISTERED ||= 0;
 625
 626 {
 627     $autoload_recursion   ||= 0;
 628
 629     #-> sub CPAN::Shell::AUTOLOAD ;
 630     sub AUTOLOAD {
 631         $autoload_recursion++;
 632         my($l) = $AUTOLOAD;
 633         my $class = shift(@_);
 634         # warn "autoload[$l] class[$class]";
 635         $l =~ s/.*:://;
 636         if ($CPAN::Signal) {
 637             warn "Refusing to autoload '$l' while signal pending";
 638             $autoload_recursion--;
 639             return;
 640         }
 641         if ($autoload_recursion > 1) {
 642             my $fullcommand = join " ", map { "'$_'" } $l, @_;
 643             warn "Refusing to autoload $fullcommand in recursion\n";
 644             $autoload_recursion--;
 645             return;
 646         }
 647         if ($l =~ /^w/) {
 648             # XXX needs to be reconsidered
 649             if ($CPAN::META->has_inst('CPAN::WAIT')) {
 650                 CPAN::WAIT->$l(@_);
 651             } else {
 652                 $CPAN::Frontend->mywarn(qq{
 653 Commands starting with "w" require CPAN::WAIT to be installed.
 654 Please consider installing CPAN::WAIT to use the fulltext index.
 655 For this you just need to type
 656     install CPAN::WAIT
 657 });
 658             }
 659         } else {
 660             $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }.
 661                                     qq{Type ? for help.
 662 });
 663         }
 664         $autoload_recursion--;
 665     }
 666 }
 667
 668 package CPAN;
 669 use strict;
 670
 671 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
 672
 673 # from here on only subs.
 674 ################################################################################
 675
 676 sub _perl_fingerprint {
 677     my($self,$other_fingerprint) = @_;
 678     my $dll = eval {OS2::DLLname()};
 679     my $mtime_dll = 0;
 680     if (defined $dll) {
 681         $mtime_dll = (-f $dll ? (stat(_))[9] : '-1');
 682     }
 683     my $this_fingerprint = {
 684                             '$^X' => $^X,
 685                             sitearchexp => $Config::Config{sitearchexp},
 686                             'mtime_$^X' => (stat $^X)[9],
 687                             'mtime_dll' => $mtime_dll,
 688                            };
 689     if ($other_fingerprint) {
 690         if (exists $other_fingerprint->{'stat($^X)'}) { # repair fp from rev. 1.88_57
 691             $other_fingerprint->{'mtime_$^X'} = $other_fingerprint->{'stat($^X)'}[9];
 692         }
 693         # mandatory keys since 1.88_57
 694         for my $key (qw($^X sitearchexp mtime_dll mtime_$^X)) {
 695             return unless $other_fingerprint->{$key} eq $this_fingerprint->{$key};
 696         }
 697         return 1;
 698     } else {
 699         return $this_fingerprint;
 700     }
 701 }
 702
 703 sub suggest_myconfig () {
 704   SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) {
 705         $CPAN::Frontend->myprint("You don't seem to have a user ".
 706                                  "configuration (MyConfig.pm) yet.\n");
 707         my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ".
 708                                               "user configuration now? (Y/n)",
 709                                               "yes");
 710         if($new =~ m{^y}i) {
 711             CPAN::Shell->mkmyconfig();
 712             return &checklock;
 713         } else {
 714             $CPAN::Frontend->mydie("OK, giving up.");
 715         }
 716     }
 717 }
 718
 719 #-> sub CPAN::all_objects ;
 720 sub all_objects {
 721     my($mgr,$class) = @_;
 722     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 723     CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
 724     CPAN::Index->reload;
 725     values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
 726 }
 727
 728 # Called by shell, not in batch mode. In batch mode I see no risk in
 729 # having many processes updating something as installations are
 730 # continually checked at runtime. In shell mode I suspect it is
 731 # unintentional to open more than one shell at a time
 732
 733 #-> sub CPAN::checklock ;
 734 sub checklock {
 735     my($self) = @_;
 736     my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
 737     if (-f $lockfile && -M _ > 0) {
 738         my $fh = FileHandle->new($lockfile) or
 739             $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
 740         my $otherpid  = <$fh>;
 741         my $otherhost = <$fh>;
 742         $fh->close;
 743         if (defined $otherpid && $otherpid) {
 744             chomp $otherpid;
 745         }
 746         if (defined $otherhost && $otherhost) {
 747             chomp $otherhost;
 748         }
 749         my $thishost  = hostname();
 750         if (defined $otherhost && defined $thishost &&
 751             $otherhost ne '' && $thishost ne '' &&
 752             $otherhost ne $thishost) {
 753             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
 754                                            "reports other host $otherhost and other ".
 755                                            "process $otherpid.\n".
 756                                            "Cannot proceed.\n"));
 757         } elsif ($RUN_DEGRADED) {
 758             $CPAN::Frontend->mywarn("Running in degraded mode (experimental)\n");
 759         } elsif (defined $otherpid && $otherpid) {
 760             return if $$ == $otherpid; # should never happen
 761             $CPAN::Frontend->mywarn(
 762                                     qq{
 763 There seems to be running another CPAN process (pid $otherpid).  Contacting...
 764 });
 765             if (kill 0, $otherpid) {
 766                 $CPAN::Frontend->mywarn(qq{Other job is running.\n});
 767                 my($ans) =
 768                     CPAN::Shell::colorable_makemaker_prompt
 769                         (qq{Shall I try to run in degraded }.
 770                          qq{mode? (Y/n)},"y");
 771                 if ($ans =~ /^y/i) {
 772                     $CPAN::Frontend->mywarn("Running in degraded mode (experimental).
 773 Please report if something unexpected happens\n");
 774                     $RUN_DEGRADED = 1;
 775                     for ($CPAN::Config) {
 776                         # XXX
 777                         # $_->{build_dir_reuse} = 0; # 2006-11-17 akoenig Why was that?
 778                         $_->{commandnumber_in_prompt} = 0; # visibility
 779                         $_->{histfile} = "";               # who should win otherwise?
 780                         $_->{cache_metadata} = 0;          # better would be a lock?
 781                     }
 782                 } else {
 783                     $CPAN::Frontend->mydie("
 784 You may want to kill the other job and delete the lockfile. On UNIX try:
 785     kill $otherpid
 786     rm $lockfile
 787 ");
 788                 }
 789             } elsif (-w $lockfile) {
 790                 my($ans) =
 791                     CPAN::Shell::colorable_makemaker_prompt
 792                         (qq{Other job not responding. Shall I overwrite }.
 793                          qq{the lockfile '$lockfile'? (Y/n)},"y");
 794                 $CPAN::Frontend->myexit("Ok, bye\n")
 795                     unless $ans =~ /^y/i;
 796             } else {
 797                 Carp::croak(
 798                             qq{Lockfile '$lockfile' not writeable by you. }.
 799                             qq{Cannot proceed.\n}.
 800                             qq{    On UNIX try:\n}.
 801                             qq{    rm '$lockfile'\n}.
 802                             qq{  and then rerun us.\n}
 803                            );
 804             }
 805         } else {
 806             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Found invalid lockfile ".
 807                                            "'$lockfile', please remove. Cannot proceed.\n"));
 808         }
 809     }
 810     my $dotcpan = $CPAN::Config->{cpan_home};
 811     eval { File::Path::mkpath($dotcpan);};
 812     if ($@) {
 813         # A special case at least for Jarkko.
 814         my $firsterror = $@;
 815         my $seconderror;
 816         my $symlinkcpan;
 817         if (-l $dotcpan) {
 818             $symlinkcpan = readlink $dotcpan;
 819             die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
 820             eval { File::Path::mkpath($symlinkcpan); };
 821             if ($@) {
 822                 $seconderror = $@;
 823             } else {
 824                 $CPAN::Frontend->mywarn(qq{
 825 Working directory $symlinkcpan created.
 826 });
 827             }
 828         }
 829         unless (-d $dotcpan) {
 830             my $mess = qq{
 831 Your configuration suggests "$dotcpan" as your
 832 CPAN.pm working directory. I could not create this directory due
 833 to this error: $firsterror\n};
 834             $mess .= qq{
 835 As "$dotcpan" is a symlink to "$symlinkcpan",
 836 I tried to create that, but I failed with this error: $seconderror
 837 } if $seconderror;
 838             $mess .= qq{
 839 Please make sure the directory exists and is writable.
 840 };
 841             $CPAN::Frontend->myprint($mess);
 842             return suggest_myconfig;
 843         }
 844     } # $@ after eval mkpath $dotcpan
 845     if (0) { # to test what happens when a race condition occurs
 846         for (reverse 1..10) {
 847             print $_, "\n";
 848             sleep 1;
 849         }
 850     }
 851     # locking
 852     if (!$RUN_DEGRADED && !$self->{LOCKFH}) {
 853         my $fh;
 854         unless ($fh = FileHandle->new("+>>$lockfile")) {
 855             if ($! =~ /Permission/) {
 856                 $CPAN::Frontend->myprint(qq{
 857
 858 Your configuration suggests that CPAN.pm should use a working
 859 directory of
 860     $CPAN::Config->{cpan_home}
 861 Unfortunately we could not create the lock file
 862     $lockfile
 863 due to permission problems.
 864
 865 Please make sure that the configuration variable
 866     \$CPAN::Config->{cpan_home}
 867 points to a directory where you can write a .lock file. You can set
 868 this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
 869 \@INC path;
 870 });
 871                 return suggest_myconfig;
 872             }
 873         }
 874         my $sleep = 1;
 875         while (!flock $fh, LOCK_EX|LOCK_NB) {
 876             if ($sleep>10) {
 877                 $CPAN::Frontend->mydie("Giving up\n");
 878             }
 879             $CPAN::Frontend->mysleep($sleep++);
 880             $CPAN::Frontend->mywarn("Could not lock lockfile with flock: $!; retrying\n");
 881         }
 882
 883         seek $fh, 0, 0;
 884         truncate $fh, 0;
 885         $fh->print($$, "\n");
 886         $fh->print(hostname(), "\n");
 887         $self->{LOCK} = $lockfile;
 888         $self->{LOCKFH} = $fh;
 889     }
 890     $SIG{TERM} = sub {
 891         my $sig = shift;
 892         &cleanup;
 893         $CPAN::Frontend->mydie("Got SIG$sig, leaving");
 894     };
 895     $SIG{INT} = sub {
 896       # no blocks!!!
 897         my $sig = shift;
 898         &cleanup if $Signal;
 899         die "Got yet another signal" if $Signal > 1;
 900         $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal;
 901         $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n");
 902         $Signal++;
 903     };
 904
 905 #       From: Larry Wall <larry@wall.org>
 906 #       Subject: Re: deprecating SIGDIE
 907 #       To: perl5-porters@perl.org
 908 #       Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
 909 #
 910 #       The original intent of __DIE__ was only to allow you to substitute one
 911 #       kind of death for another on an application-wide basis without respect
 912 #       to whether you were in an eval or not.  As a global backstop, it should
 913 #       not be used any more lightly (or any more heavily :-) than class
 914 #       UNIVERSAL.  Any attempt to build a general exception model on it should
 915 #       be politely squashed.  Any bug that causes every eval {} to have to be
 916 #       modified should be not so politely squashed.
 917 #
 918 #       Those are my current opinions.  It is also my optinion that polite
 919 #       arguments degenerate to personal arguments far too frequently, and that
 920 #       when they do, it's because both people wanted it to, or at least didn't
 921 #       sufficiently want it not to.
 922 #
 923 #       Larry
 924
 925     # global backstop to cleanup if we should really die
 926     $SIG{__DIE__} = \&cleanup;
 927     $self->debug("Signal handler set.") if $CPAN::DEBUG;
 928 }
 929
 930 #-> sub CPAN::DESTROY ;
 931 sub DESTROY {
 932     &cleanup; # need an eval?
 933 }
 934
 935 #-> sub CPAN::anycwd ;
 936 sub anycwd () {
 937     my $getcwd;
 938     $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
 939     CPAN->$getcwd();
 940 }
 941
 942 #-> sub CPAN::cwd ;
 943 sub cwd {Cwd::cwd();}
 944
 945 #-> sub CPAN::getcwd ;
 946 sub getcwd {Cwd::getcwd();}
 947
 948 #-> sub CPAN::fastcwd ;
 949 sub fastcwd {Cwd::fastcwd();}
 950
 951 #-> sub CPAN::backtickcwd ;
 952 sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
 953
 954 #-> sub CPAN::find_perl ;
 955 sub find_perl {
 956     my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
 957     my $pwd  = $CPAN::iCwd = CPAN::anycwd();
 958     my $candidate = File::Spec->catfile($pwd,$^X);
 959     $perl ||= $candidate if MM->maybe_command($candidate);
 960
 961     unless ($perl) {
 962         my ($component,$perl_name);
 963       DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
 964             PATH_COMPONENT: foreach $component (File::Spec->path(),
 965                                                 $Config::Config{'binexp'}) {
 966                   next unless defined($component) && $component;
 967                   my($abs) = File::Spec->catfile($component,$perl_name);
 968                   if (MM->maybe_command($abs)) {
 969                       $perl = $abs;
 970                       last DIST_PERLNAME;
 971                   }
 972               }
 973           }
 974     }
 975
 976     return $perl;
 977 }
 978
 979
 980 #-> sub CPAN::exists ;
 981 sub exists {
 982     my($mgr,$class,$id) = @_;
 983     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 984     CPAN::Index->reload;
 985     ### Carp::croak "exists called without class argument" unless $class;
 986     $id ||= "";
 987     $id =~ s/:+/::/g if $class eq "CPAN::Module";
 988     my $exists;
 989     if (CPAN::_sqlite_running) {
 990         $exists = (exists $META->{readonly}{$class}{$id} or
 991                    $CPAN::SQLite->set($class, $id));
 992     } else {
 993         $exists =  exists $META->{readonly}{$class}{$id};
 994     }
 995     $exists ||= exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
 996 }
 997
 998 #-> sub CPAN::delete ;
 999 sub delete {
1000   my($mgr,$class,$id) = @_;
1001   delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
1002   delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
1003 }
1004
1005 #-> sub CPAN::has_usable
1006 # has_inst is sometimes too optimistic, we should replace it with this
1007 # has_usable whenever a case is given
1008 sub has_usable {
1009     my($self,$mod,$message) = @_;
1010     return 1 if $HAS_USABLE->{$mod};
1011     my $has_inst = $self->has_inst($mod,$message);
1012     return unless $has_inst;
1013     my $usable;
1014     $usable = {
1015                LWP => [ # we frequently had "Can't locate object
1016                         # method "new" via package "LWP::UserAgent" at
1017                         # (eval 69) line 2006
1018                        sub {require LWP},
1019                        sub {require LWP::UserAgent},
1020                        sub {require HTTP::Request},
1021                        sub {require URI::URL},
1022                       ],
1023                'Net::FTP' => [
1024                             sub {require Net::FTP},
1025                             sub {require Net::Config},
1026                            ],
1027                'File::HomeDir' => [
1028                                    sub {require File::HomeDir;
1029                                         unless (File::HomeDir::->VERSION >= 0.52){
1030                                             for ("Will not use File::HomeDir, need 0.52\n") {
1031                                                 $CPAN::Frontend->mywarn($_);
1032                                                 die $_;
1033                                             }
1034                                         }
1035                                     },
1036                                   ],
1037               };
1038     if ($usable->{$mod}) {
1039         for my $c (0..$#{$usable->{$mod}}) {
1040             my $code = $usable->{$mod}[$c];
1041             my $ret = eval { &$code() };
1042             $ret = "" unless defined $ret;
1043             if ($@) {
1044                 # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
1045                 return;
1046             }
1047         }
1048     }
1049     return $HAS_USABLE->{$mod} = 1;
1050 }
1051
1052 #-> sub CPAN::has_inst
1053 sub has_inst {
1054     my($self,$mod,$message) = @_;
1055     Carp::croak("CPAN->has_inst() called without an argument")
1056         unless defined $mod;
1057     my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
1058         keys %{$CPAN::Config->{dontload_hash}||{}},
1059             @{$CPAN::Config->{dontload_list}||[]};
1060     if (defined $message && $message eq "no"  # afair only used by Nox
1061         ||
1062         $dont{$mod}
1063        ) {
1064       $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
1065       return 0;
1066     }
1067     my $file = $mod;
1068     my $obj;
1069     $file =~ s|::|/|g;
1070     $file .= ".pm";
1071     if ($INC{$file}) {
1072         # checking %INC is wrong, because $INC{LWP} may be true
1073         # although $INC{"URI/URL.pm"} may have failed. But as
1074         # I really want to say "bla loaded OK", I have to somehow
1075         # cache results.
1076         ### warn "$file in %INC"; #debug
1077         return 1;
1078     } elsif (eval { require $file }) {
1079         # eval is good: if we haven't yet read the database it's
1080         # perfect and if we have installed the module in the meantime,
1081         # it tries again. The second require is only a NOOP returning
1082         # 1 if we had success, otherwise it's retrying
1083
1084         my $v = eval "\$$mod\::VERSION";
1085         $v = $v ? " (v$v)" : "";
1086         $CPAN::Frontend->myprint("CPAN: $mod loaded ok$v\n");
1087         if ($mod eq "CPAN::WAIT") {
1088             push @CPAN::Shell::ISA, 'CPAN::WAIT';
1089         }
1090         return 1;
1091     } elsif ($mod eq "Net::FTP") {
1092         $CPAN::Frontend->mywarn(qq{
1093   Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
1094   if you just type
1095       install Bundle::libnet
1096
1097 }) unless $Have_warned->{"Net::FTP"}++;
1098         $CPAN::Frontend->mysleep(3);
1099     } elsif ($mod eq "Digest::SHA"){
1100         if ($Have_warned->{"Digest::SHA"}++) {
1101             $CPAN::Frontend->myprint(qq{CPAN: checksum security checks disabled}.
1102                                      qq{because Digest::SHA not installed.\n});
1103         } else {
1104             $CPAN::Frontend->mywarn(qq{
1105   CPAN: checksum security checks disabled because Digest::SHA not installed.
1106   Please consider installing the Digest::SHA module.
1107
1108 });
1109             $CPAN::Frontend->mysleep(2);
1110         }
1111     } elsif ($mod eq "Module::Signature"){
1112         # NOT prefs_lookup, we are not a distro
1113         my $check_sigs = $CPAN::Config->{check_sigs};
1114         if (not $check_sigs) {
1115             # they do not want us:-(
1116         } elsif (not $Have_warned->{"Module::Signature"}++) {
1117             # No point in complaining unless the user can
1118             # reasonably install and use it.
1119             if (eval { require Crypt::OpenPGP; 1 } ||
1120                 (
1121                  defined $CPAN::Config->{'gpg'}
1122                  &&
1123                  $CPAN::Config->{'gpg'} =~ /\S/
1124                 )
1125                ) {
1126                 $CPAN::Frontend->mywarn(qq{
1127   CPAN: Module::Signature security checks disabled because Module::Signature
1128   not installed.  Please consider installing the Module::Signature module.
1129   You may also need to be able to connect over the Internet to the public
1130   keyservers like pgp.mit.edu (port 11371).
1131
1132 });
1133                 $CPAN::Frontend->mysleep(2);
1134             }
1135         }
1136     } else {
1137         delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
1138     }
1139     return 0;
1140 }
1141
1142 #-> sub CPAN::instance ;
1143 sub instance {
1144     my($mgr,$class,$id) = @_;
1145     CPAN::Index->reload;
1146     $id ||= "";
1147     # unsafe meta access, ok?
1148     return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
1149     $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
1150 }
1151
1152 #-> sub CPAN::new ;
1153 sub new {
1154     bless {}, shift;
1155 }
1156
1157 #-> sub CPAN::cleanup ;
1158 sub cleanup {
1159   # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
1160   local $SIG{__DIE__} = '';
1161   my($message) = @_;
1162   my $i = 0;
1163   my $ineval = 0;
1164   my($subroutine);
1165   while ((undef,undef,undef,$subroutine) = caller(++$i)) {
1166       $ineval = 1, last if
1167           $subroutine eq '(eval)';
1168   }
1169   return if $ineval && !$CPAN::End;
1170   return unless defined $META->{LOCK};
1171   return unless -f $META->{LOCK};
1172   $META->savehist;
1173   unlink $META->{LOCK};
1174   # require Carp;
1175   # Carp::cluck("DEBUGGING");
1176   if ( $CPAN::CONFIG_DIRTY ) {
1177       $CPAN::Frontend->mywarn("Warning: Configuration not saved.\n");
1178   }
1179   $CPAN::Frontend->myprint("Lockfile removed.\n");
1180 }
1181
1182 #-> sub CPAN::savehist
1183 sub savehist {
1184     my($self) = @_;
1185     my($histfile,$histsize);
1186     unless ($histfile = $CPAN::Config->{'histfile'}){
1187         $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
1188         return;
1189     }
1190     $histsize = $CPAN::Config->{'histsize'} || 100;
1191     if ($CPAN::term){
1192         unless ($CPAN::term->can("GetHistory")) {
1193             $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
1194             return;
1195         }
1196     } else {
1197         return;
1198     }
1199     my @h = $CPAN::term->GetHistory;
1200     splice @h, 0, @h-$histsize if @h>$histsize;
1201     my($fh) = FileHandle->new;
1202     open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
1203     local $\ = local $, = "\n";
1204     print $fh @h;
1205     close $fh;
1206 }
1207
1208 #-> sub CPAN::is_tested
1209 sub is_tested {
1210     my($self,$what) = @_;
1211     $self->{is_tested}{$what} = 1;
1212 }
1213
1214 #-> sub CPAN::is_installed
1215 # unsets the is_tested flag: as soon as the thing is installed, it is
1216 # not needed in set_perl5lib anymore
1217 sub is_installed {
1218     my($self,$what) = @_;
1219     delete $self->{is_tested}{$what};
1220 }
1221
1222 #-> sub CPAN::set_perl5lib
1223 sub set_perl5lib {
1224     my($self,$for) = @_;
1225     unless ($for) {
1226         (undef,undef,undef,$for) = caller(1);
1227         $for =~ s/.*://;
1228     }
1229     $self->{is_tested} ||= {};
1230     return unless %{$self->{is_tested}};
1231     my $env = $ENV{PERL5LIB};
1232     $env = $ENV{PERLLIB} unless defined $env;
1233     my @env;
1234     push @env, $env if defined $env and length $env;
1235     #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
1236     #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
1237     my @dirs = map {("$_/blib/arch", "$_/blib/lib")} sort keys %{$self->{is_tested}};
1238     if (@dirs < 15) {
1239         $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB for $for\n");
1240     } else {
1241         my @d = map {s/^\Q$CPAN::Config->{'build_dir'}/%BUILDDIR%/; $_ }
1242             sort keys %{$self->{is_tested}};
1243         $CPAN::Frontend->myprint("Prepending blib/arch and blib/lib subdirs of ".
1244                                  "@d to PERL5LIB; ".
1245                                  "%BUILDDIR%=$CPAN::Config->{'build_dir'} ".
1246                                  "for $for\n"
1247                                 );
1248     }
1249
1250     $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1251 }
1252
1253 package CPAN::CacheMgr;
1254 use strict;
1255
1256 #-> sub CPAN::CacheMgr::as_string ;
1257 sub as_string {
1258     eval { require Data::Dumper };
1259     if ($@) {
1260         return shift->SUPER::as_string;
1261     } else {
1262         return Data::Dumper::Dumper(shift);
1263     }
1264 }
1265
1266 #-> sub CPAN::CacheMgr::cachesize ;
1267 sub cachesize {
1268     shift->{DU};
1269 }
1270
1271 #-> sub CPAN::CacheMgr::tidyup ;
1272 sub tidyup {
1273   my($self) = @_;
1274   return unless $CPAN::META->{LOCK};
1275   return unless -d $self->{ID};
1276   while ($self->{DU} > $self->{'MAX'} ) {
1277     my($toremove) = shift @{$self->{FIFO}};
1278     unless ($toremove =~ /\.yml$/) {
1279         $CPAN::Frontend->myprint(sprintf(
1280                                          "Deleting from cache".
1281                                          ": $toremove (%.1f>%.1f MB)\n",
1282                                          $self->{DU}, $self->{'MAX'})
1283                                 );
1284     }
1285     return if $CPAN::Signal;
1286     $self->_clean_cache($toremove);
1287     return if $CPAN::Signal;
1288   }
1289 }
1290
1291 #-> sub CPAN::CacheMgr::dir ;
1292 sub dir {
1293     shift->{ID};
1294 }
1295
1296 #-> sub CPAN::CacheMgr::entries ;
1297 sub entries {
1298     my($self,$dir) = @_;
1299     return unless defined $dir;
1300     $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
1301     $dir ||= $self->{ID};
1302     my($cwd) = CPAN::anycwd();
1303     chdir $dir or Carp::croak("Can't chdir to $dir: $!");
1304     my $dh = DirHandle->new(File::Spec->curdir)
1305         or Carp::croak("Couldn't opendir $dir: $!");
1306     my(@entries);
1307     for ($dh->read) {
1308         next if $_ eq "." || $_ eq "..";
1309         if (-f $_) {
1310             push @entries, File::Spec->catfile($dir,$_);
1311         } elsif (-d _) {
1312             push @entries, File::Spec->catdir($dir,$_);
1313         } else {
1314             $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
1315         }
1316     }
1317     chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
1318     sort { -M $b <=> -M $a} @entries;
1319 }
1320
1321 #-> sub CPAN::CacheMgr::disk_usage ;
1322 sub disk_usage {
1323     my($self,$dir) = @_;
1324     return if exists $self->{SIZE}{$dir};
1325     return if $CPAN::Signal;
1326     my($Du) = 0;
1327     if (-e $dir) {
1328         unless (-x $dir) {
1329             unless (chmod 0755, $dir) {
1330                 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
1331                                         "permission to change the permission; cannot ".
1332                                         "estimate disk usage of '$dir'\n");
1333                 $CPAN::Frontend->mysleep(5);
1334                 return;
1335             }
1336         }
1337     } else {
1338         $CPAN::Frontend->mywarn("Directory '$dir' has gone. Cannot continue.\n");
1339         return;
1340     }
1341     find(
1342          sub {
1343            $File::Find::prune++ if $CPAN::Signal;
1344            return if -l $_;
1345            if ($^O eq 'MacOS') {
1346              require Mac::Files;
1347              my $cat  = Mac::Files::FSpGetCatInfo($_);
1348              $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
1349            } else {
1350              if (-d _) {
1351                unless (-x _) {
1352                  unless (chmod 0755, $_) {
1353                    $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
1354                                            "the permission to change the permission; ".
1355                                            "can only partially estimate disk usage ".
1356                                            "of '$_'\n");
1357                    $CPAN::Frontend->mysleep(5);
1358                    return;
1359                  }
1360                }
1361              } else {
1362                $Du += (-s _);
1363              }
1364            }
1365          },
1366          $dir
1367         );
1368     return if $CPAN::Signal;
1369     $self->{SIZE}{$dir} = $Du/1024/1024;
1370     push @{$self->{FIFO}}, $dir;
1371     $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
1372     $self->{DU} += $Du/1024/1024;
1373     $self->{DU};
1374 }
1375
1376 #-> sub CPAN::CacheMgr::_clean_cache ;
1377 sub _clean_cache {
1378     my($self,$dir) = @_;
1379     return unless -e $dir;
1380     unless (File::Spec->canonpath(File::Basename::dirname($dir))
1381             eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
1382         $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
1383                                 "will not remove\n");
1384         $CPAN::Frontend->mysleep(5);
1385         return;
1386     }
1387     $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
1388         if $CPAN::DEBUG;
1389     File::Path::rmtree($dir);
1390     unlink "$dir.yml"; # may fail
1391     $self->{DU} -= $self->{SIZE}{$dir};
1392     delete $self->{SIZE}{$dir};
1393 }
1394
1395 #-> sub CPAN::CacheMgr::new ;
1396 sub new {
1397     my $class = shift;
1398     my $time = time;
1399     my($debug,$t2);
1400     $debug = "";
1401     my $self = {
1402                 ID => $CPAN::Config->{'build_dir'},
1403                 MAX => $CPAN::Config->{'build_cache'},
1404                 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
1405                 DU => 0
1406                };
1407     File::Path::mkpath($self->{ID});
1408     my $dh = DirHandle->new($self->{ID});
1409     bless $self, $class;
1410     $self->scan_cache;
1411     $t2 = time;
1412     $debug .= "timing of CacheMgr->new: ".($t2 - $time);
1413     $time = $t2;
1414     CPAN->debug($debug) if $CPAN::DEBUG;
1415     $self;
1416 }
1417
1418 #-> sub CPAN::CacheMgr::scan_cache ;
1419 sub scan_cache {
1420     my $self = shift;
1421     return if $self->{SCAN} eq 'never';
1422     $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
1423         unless $self->{SCAN} eq 'atstart';
1424     $CPAN::Frontend->myprint(
1425                              sprintf("Scanning cache %s for sizes\n",
1426                                      $self->{ID}));
1427     my $e;
1428     for $e ($self->entries($self->{ID})) {
1429         next if $e eq ".." || $e eq ".";
1430         $self->disk_usage($e);
1431         return if $CPAN::Signal;
1432     }
1433     $self->tidyup;
1434 }
1435
1436 package CPAN::Shell;
1437 use strict;
1438
1439 #-> sub CPAN::Shell::h ;
1440 sub h {
1441     my($class,$about) = @_;
1442     if (defined $about) {
1443         $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1444     } else {
1445         my $filler = " " x (80 - 28 - length($CPAN::VERSION));
1446         $CPAN::Frontend->myprint(qq{
1447 Display Information $filler (ver $CPAN::VERSION)
1448  command  argument          description
1449  a,b,d,m  WORD or /REGEXP/  about authors, bundles, distributions, modules
1450  i        WORD or /REGEXP/  about any of the above
1451  ls       AUTHOR or GLOB    about files in the author's directory
1452     (with WORD being a module, bundle or author name or a distribution
1453     name of the form AUTHOR/DISTRIBUTION)
1454
1455 Download, Test, Make, Install...
1456  get      download                     clean    make clean
1457  make     make (implies get)           look     open subshell in dist directory
1458  test     make test (implies make)     readme   display these README files
1459  install  make install (implies test)  perldoc  display POD documentation
1460
1461 Upgrade
1462  r        WORDs or /REGEXP/ or NONE    report updates for some/matching/all modules
1463  upgrade  WORDs or /REGEXP/ or NONE    upgrade some/matching/all modules
1464
1465 Pragmas
1466  force  CMD    try hard to do command
1467  notest CMD    skip testing
1468
1469 Other
1470  h,?           display this menu       ! perl-code   eval a perl command
1471  o conf [opt]  set and query options   q             quit the cpan shell
1472  reload cpan   load CPAN.pm again      reload index  load newer indices
1473  autobundle    Snapshot                recent        latest CPAN uploads});
1474 }
1475 }
1476
1477 *help = \&h;
1478
1479 #-> sub CPAN::Shell::a ;
1480 sub a {
1481   my($self,@arg) = @_;
1482   # authors are always UPPERCASE
1483   for (@arg) {
1484     $_ = uc $_ unless /=/;
1485   }
1486   $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1487 }
1488
1489 #-> sub CPAN::Shell::globls ;
1490 sub globls {
1491     my($self,$s,$pragmas) = @_;
1492     # ls is really very different, but we had it once as an ordinary
1493     # command in the Shell (upto rev. 321) and we could not handle
1494     # force well then
1495     my(@accept,@preexpand);
1496     if ($s =~ /[\*\?\/]/) {
1497         if ($CPAN::META->has_inst("Text::Glob")) {
1498             if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
1499                 my $rau = Text::Glob::glob_to_regex(uc $au);
1500                 CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
1501                       if $CPAN::DEBUG;
1502                 push @preexpand, map { $_->id . "/" . $pathglob }
1503                     CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
1504             } else {
1505                 my $rau = Text::Glob::glob_to_regex(uc $s);
1506                 push @preexpand, map { $_->id }
1507                     CPAN::Shell->expand_by_method('CPAN::Author',
1508                                                   ['id'],
1509                                                   "/$rau/");
1510             }
1511         } else {
1512             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
1513         }
1514     } else {
1515         push @preexpand, uc $s;
1516     }
1517     for (@preexpand) {
1518         unless (/^[A-Z0-9\-]+(\/|$)/i) {
1519             $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
1520             next;
1521         }
1522         push @accept, $_;
1523     }
1524     my $silent = @accept>1;
1525     my $last_alpha = "";
1526     my @results;
1527     for my $a (@accept){
1528         my($author,$pathglob);
1529         if ($a =~ m|(.*?)/(.*)|) {
1530             my $a2 = $1;
1531             $pathglob = $2;
1532             $author = CPAN::Shell->expand_by_method('CPAN::Author',
1533                                                     ['id'],
1534                                                     $a2) or die "No author found for $a2";
1535         } else {
1536             $author = CPAN::Shell->expand_by_method('CPAN::Author',
1537                                                     ['id'],
1538                                                     $a) or die "No author found for $a";
1539         }
1540         if ($silent) {
1541             my $alpha = substr $author->id, 0, 1;
1542             my $ad;
1543             if ($alpha eq $last_alpha) {
1544                 $ad = "";
1545             } else {
1546                 $ad = "[$alpha]";
1547                 $last_alpha = $alpha;
1548             }
1549             $CPAN::Frontend->myprint($ad);
1550         }
1551         for my $pragma (@$pragmas) {
1552             if ($author->can($pragma)) {
1553                 $author->$pragma();
1554             }
1555         }
1556         push @results, $author->ls($pathglob,$silent); # silent if
1557                                                        # more than one
1558                                                        # author
1559         for my $pragma (@$pragmas) {
1560             my $unpragma = "un$pragma";
1561             if ($author->can($unpragma)) {
1562                 $author->$unpragma();
1563             }
1564         }
1565     }
1566     @results;
1567 }
1568
1569 #-> sub CPAN::Shell::local_bundles ;
1570 sub local_bundles {
1571     my($self,@which) = @_;
1572     my($incdir,$bdir,$dh);
1573     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1574         my @bbase = "Bundle";
1575         while (my $bbase = shift @bbase) {
1576             $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
1577             CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1578             if ($dh = DirHandle->new($bdir)) { # may fail
1579                 my($entry);
1580                 for $entry ($dh->read) {
1581                     next if $entry =~ /^\./;
1582                     next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/;
1583                     if (-d File::Spec->catdir($bdir,$entry)){
1584                         push @bbase, "$bbase\::$entry";
1585                     } else {
1586                         next unless $entry =~ s/\.pm(?!\n)\Z//;
1587                         $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1588                     }
1589                 }
1590             }
1591         }
1592     }
1593 }
1594
1595 #-> sub CPAN::Shell::b ;
1596 sub b {
1597     my($self,@which) = @_;
1598     CPAN->debug("which[@which]") if $CPAN::DEBUG;
1599     $self->local_bundles;
1600     $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1601 }
1602
1603 #-> sub CPAN::Shell::d ;
1604 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1605
1606 #-> sub CPAN::Shell::m ;
1607 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1608     my $self = shift;
1609     $CPAN::Frontend->myprint($self->format_result('Module',@_));
1610 }
1611
1612 #-> sub CPAN::Shell::i ;
1613 sub i {
1614     my($self) = shift;
1615     my(@args) = @_;
1616     @args = '/./' unless @args;
1617     my(@result);
1618     for my $type (qw/Bundle Distribution Module/) {
1619         push @result, $self->expand($type,@args);
1620     }
1621     # Authors are always uppercase.
1622     push @result, $self->expand("Author", map { uc $_ } @args);
1623
1624     my $result = @result == 1 ?
1625         $result[0]->as_string :
1626             @result == 0 ?
1627                 "No objects found of any type for argument @args\n" :
1628                     join("",
1629                          (map {$_->as_glimpse} @result),
1630                          scalar @result, " items found\n",
1631                         );
1632     $CPAN::Frontend->myprint($result);
1633 }
1634
1635 #-> sub CPAN::Shell::o ;
1636
1637 # CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o
1638 # conf' calls through to CPAN::HandleConfig::edit. 'o conf' should
1639 # probably have been called 'set' and 'o debug' maybe 'set debug' or
1640 # 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm
1641 sub o {
1642     my($self,$o_type,@o_what) = @_;
1643     $o_type ||= "";
1644     CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1645     if ($o_type eq 'conf') {
1646         if (!@o_what) { # print all things, "o conf"
1647             my($k,$v);
1648             $CPAN::Frontend->myprint("\$CPAN::Config options from ");
1649             my @from;
1650             if (exists $INC{'CPAN/Config.pm'}) {
1651                 push @from, $INC{'CPAN/Config.pm'};
1652             }
1653             if (exists $INC{'CPAN/MyConfig.pm'}) {
1654                 push @from, $INC{'CPAN/MyConfig.pm'};
1655             }
1656             $CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from);
1657             $CPAN::Frontend->myprint(":\n");
1658             for $k (sort keys %CPAN::HandleConfig::can) {
1659                 $v = $CPAN::HandleConfig::can{$k};
1660                 $CPAN::Frontend->myprint(sprintf "    %-18s [%s]\n", $k, $v);
1661             }
1662             $CPAN::Frontend->myprint("\n");
1663             for $k (sort keys %$CPAN::Config) {
1664                 CPAN::HandleConfig->prettyprint($k);
1665             }
1666             $CPAN::Frontend->myprint("\n");
1667         } else {
1668             if (CPAN::HandleConfig->edit(@o_what)) {
1669                 unless ($o_what[0] =~ /^(init|commit|defaults)$/) {
1670                     $CPAN::Frontend->myprint("Please use 'o conf commit' to ".
1671                                              "make the config permanent!\n\n");
1672                 }
1673             } else {
1674                 $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
1675                                          qq{items\n\n});
1676             }
1677         }
1678     } elsif ($o_type eq 'debug') {
1679         my(%valid);
1680         @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1681         if (@o_what) {
1682             while (@o_what) {
1683                 my($what) = shift @o_what;
1684                 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
1685                     $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
1686                     next;
1687                 }
1688                 if ( exists $CPAN::DEBUG{$what} ) {
1689                     $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1690                 } elsif ($what =~ /^\d/) {
1691                     $CPAN::DEBUG = $what;
1692                 } elsif (lc $what eq 'all') {
1693                     my($max) = 0;
1694                     for (values %CPAN::DEBUG) {
1695                         $max += $_;
1696                     }
1697                     $CPAN::DEBUG = $max;
1698                 } else {
1699                     my($known) = 0;
1700                     for (keys %CPAN::DEBUG) {
1701                         next unless lc($_) eq lc($what);
1702                         $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1703                         $known = 1;
1704                     }
1705                     $CPAN::Frontend->myprint("unknown argument [$what]\n")
1706                         unless $known;
1707                 }
1708             }
1709         } else {
1710           my $raw = "Valid options for debug are ".
1711               join(", ",sort(keys %CPAN::DEBUG), 'all').
1712                   qq{ or a number. Completion works on the options. }.
1713                       qq{Case is ignored.};
1714           require Text::Wrap;
1715           $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1716           $CPAN::Frontend->myprint("\n\n");
1717         }
1718         if ($CPAN::DEBUG) {
1719             $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n");
1720             my($k,$v);
1721             for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1722                 $v = $CPAN::DEBUG{$k};
1723                 $CPAN::Frontend->myprint(sprintf "    %-14s(%s)\n", $k, $v)
1724                     if $v & $CPAN::DEBUG;
1725             }
1726         } else {
1727             $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1728         }
1729     } else {
1730         $CPAN::Frontend->myprint(qq{
1731 Known options:
1732   conf    set or get configuration variables
1733   debug   set or get debugging options
1734 });
1735     }
1736 }
1737
1738 # CPAN::Shell::paintdots_onreload
1739 sub paintdots_onreload {
1740     my($ref) = shift;
1741     sub {
1742         if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
1743             my($subr) = $1;
1744             ++$$ref;
1745             local($|) = 1;
1746             # $CPAN::Frontend->myprint(".($subr)");
1747             $CPAN::Frontend->myprint(".");
1748             if ($subr =~ /\bshell\b/i) {
1749                 # warn "debug[$_[0]]";
1750
1751                 # It would be nice if we could detect that a
1752                 # subroutine has actually changed, but for now we
1753                 # practically always set the GOTOSHELL global
1754
1755                 $CPAN::GOTOSHELL=1;
1756             }
1757             return;
1758         }
1759         warn @_;
1760     };
1761 }
1762
1763 #-> sub CPAN::Shell::hosts ;
1764 sub hosts {
1765     my($self) = @_;
1766     my $fullstats = CPAN::FTP->_ftp_statistics();
1767     my $history = $fullstats->{history} || [];
1768     my %S; # statistics
1769     while (my $last = pop @$history) {
1770         my $attempts = $last->{attempts} or next;
1771         my $start;
1772         if (@$attempts) {
1773             $start = $attempts->[-1]{start};
1774             if ($#$attempts > 0) {
1775                 for my $i (0..$#$attempts-1) {
1776                     my $url = $attempts->[$i]{url} or next;
1777                     $S{no}{$url}++;
1778                 }
1779             }
1780         } else {
1781             $start = $last->{start};
1782         }
1783         next unless $last->{thesiteurl}; # C-C? bad filenames?
1784         $S{start} = $start;
1785         $S{end} ||= $last->{end};
1786         my $dltime = $last->{end} - $start;
1787         my $dlsize = $last->{filesize} || 0;
1788         my $url = $last->{thesiteurl}->text;
1789         my $s = $S{ok}{$url} ||= {};
1790         $s->{n}++;
1791         $s->{dlsize} ||= 0;
1792         $s->{dlsize} += $dlsize/1024;
1793         $s->{dltime} ||= 0;
1794         $s->{dltime} += $dltime;
1795     }
1796     my $res;
1797     for my $url (keys %{$S{ok}}) {
1798         next if $S{ok}{$url}{dltime} == 0; # div by zero
1799         push @{$res->{ok}}, [@{$S{ok}{$url}}{qw(n dlsize dltime)},
1800                              $S{ok}{$url}{dlsize}/$S{ok}{$url}{dltime},
1801                              $url,
1802                             ];
1803     }
1804     for my $url (keys %{$S{no}}) {
1805         push @{$res->{no}}, [$S{no}{$url},
1806                              $url,
1807                             ];
1808     }
1809     my $R = ""; # report
1810     $R .= sprintf "Log starts: %s\n", scalar(localtime $S{start}) || "unknown";
1811     $R .= sprintf "Log ends  : %s\n", scalar(localtime $S{end}) || "unknown";
1812     if ($res->{ok} && @{$res->{ok}}) {
1813         $R .= sprintf "\nSuccessful downloads:
1814    N       kB  secs      kB/s url\n";
1815         my $i = 20;
1816         for (sort { $b->[3] <=> $a->[3] } @{$res->{ok}}) {
1817             $R .= sprintf "%4d %8d %5d %9.1f %s\n", @$_;
1818             last if --$i<=0;
1819         }
1820     }
1821     if ($res->{no} && @{$res->{no}}) {
1822         $R .= sprintf "\nUnsuccessful downloads:\n";
1823         my $i = 20;
1824         for (sort { $b->[0] <=> $a->[0] } @{$res->{no}}) {
1825             $R .= sprintf "%4d %s\n", @$_;
1826             last if --$i<=0;
1827         }
1828     }
1829     $CPAN::Frontend->myprint($R);
1830 }
1831
1832 #-> sub CPAN::Shell::reload ;
1833 sub reload {
1834     my($self,$command,@arg) = @_;
1835     $command ||= "";
1836     $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1837     if ($command =~ /^cpan$/i) {
1838         my $redef = 0;
1839         chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
1840         my $failed;
1841         my @relo = (
1842                     "CPAN.pm",
1843                     "CPAN/Debug.pm",
1844                     "CPAN/FirstTime.pm",
1845                     "CPAN/HandleConfig.pm",
1846                     "CPAN/Kwalify.pm",
1847                     "CPAN/Queue.pm",
1848                     "CPAN/Reporter.pm",
1849                     "CPAN/Tarzip.pm",
1850                     "CPAN/Version.pm",
1851                    );
1852       MFILE: for my $f (@relo) {
1853             next unless exists $INC{$f};
1854             my $p = $f;
1855             $p =~ s/\.pm$//;
1856             $p =~ s|/|::|g;
1857             $CPAN::Frontend->myprint("($p");
1858             local($SIG{__WARN__}) = paintdots_onreload(\$redef);
1859             $self->_reload_this($f) or $failed++;
1860             my $v = eval "$p\::->VERSION";
1861             $CPAN::Frontend->myprint("v$v)");
1862         }
1863         $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1864         if ($failed) {
1865             my $errors = $failed == 1 ? "error" : "errors";
1866             $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ".
1867                                     "this session.\n");
1868         }
1869     } elsif ($command =~ /^index$/i) {
1870       CPAN::Index->force_reload;
1871     } else {
1872       $CPAN::Frontend->myprint(qq{cpan     re-evals the CPAN modules
1873 index    re-reads the index files\n});
1874     }
1875 }
1876
1877 # reload means only load again what we have loaded before
1878 #-> sub CPAN::Shell::_reload_this ;
1879 sub _reload_this {
1880     my($self,$f,$args) = @_;
1881     CPAN->debug("f[$f]") if $CPAN::DEBUG;
1882     return 1 unless $INC{$f}; # we never loaded this, so we do not
1883                               # reload but say OK
1884     my $pwd = CPAN::anycwd();
1885     CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG;
1886     my($file);
1887     for my $inc (@INC) {
1888         $file = File::Spec->catfile($inc,split /\//, $f);
1889         last if -f $file;
1890         $file = "";
1891     }
1892     CPAN->debug("file[$file]") if $CPAN::DEBUG;
1893     my @inc = @INC;
1894     unless ($file && -f $file) {
1895         # this thingie is not in the INC path, maybe CPAN/MyConfig.pm?
1896         $file = $INC{$f};
1897         unless (CPAN->has_inst("File::Basename")) {
1898             @inc = File::Basename::dirname($file);
1899         } else {
1900             # do we ever need this?
1901             @inc = substr($file,0,-length($f)-1); # bring in back to me!
1902         }
1903     }
1904     CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG;
1905     unless (-f $file) {
1906         $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
1907         return;
1908     }
1909     my $mtime = (stat $file)[9];
1910     $reload->{$f} ||= $^T;
1911     my $must_reload = $mtime > $reload->{$f};
1912     $args ||= {};
1913     $must_reload ||= $args->{reloforce};
1914     if ($must_reload) {
1915         my $fh = FileHandle->new($file) or
1916             $CPAN::Frontend->mydie("Could not open $file: $!");
1917         local($/);
1918         local $^W = 1;
1919         my $content = <$fh>;
1920         CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
1921             if $CPAN::DEBUG;
1922         delete $INC{$f};
1923         local @INC = @inc;
1924         eval "require '$f'";
1925         if ($@){
1926             warn $@;
1927             return;
1928         }
1929         $reload->{$f} = time;
1930     } else {
1931         $CPAN::Frontend->myprint("__unchanged__");
1932     }
1933     return 1;
1934 }
1935
1936 #-> sub CPAN::Shell::mkmyconfig ;
1937 sub mkmyconfig {
1938     my($self, $cpanpm, %args) = @_;
1939     require CPAN::FirstTime;
1940     my $home = CPAN::HandleConfig::home;
1941     $cpanpm = $INC{'CPAN/MyConfig.pm'} ||
1942         File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm");
1943     File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm;
1944     CPAN::HandleConfig::require_myconfig_or_config;
1945     $CPAN::Config ||= {};
1946     $CPAN::Config = {
1947         %$CPAN::Config,
1948         build_dir           =>  undef,
1949         cpan_home           =>  undef,
1950         keep_source_where   =>  undef,
1951         histfile            =>  undef,
1952     };
1953     CPAN::FirstTime::init($cpanpm, %args);
1954 }
1955
1956 #-> sub CPAN::Shell::_binary_extensions ;
1957 sub _binary_extensions {
1958     my($self) = shift @_;
1959     my(@result,$module,%seen,%need,$headerdone);
1960     for $module ($self->expand('Module','/./')) {
1961         my $file  = $module->cpan_file;
1962         next if $file eq "N/A";
1963         next if $file =~ /^Contact Author/;
1964         my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
1965         next if $dist->isa_perl;
1966         next unless $module->xs_file;
1967         local($|) = 1;
1968         $CPAN::Frontend->myprint(".");
1969         push @result, $module;
1970     }
1971 #    print join " | ", @result;
1972     $CPAN::Frontend->myprint("\n");
1973     return @result;
1974 }
1975
1976 #-> sub CPAN::Shell::recompile ;
1977 sub recompile {
1978     my($self) = shift @_;
1979     my($module,@module,$cpan_file,%dist);
1980     @module = $self->_binary_extensions();
1981     for $module (@module){  # we force now and compile later, so we
1982                             # don't do it twice
1983         $cpan_file = $module->cpan_file;
1984         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1985         $pack->force; #
1986         $dist{$cpan_file}++;
1987     }
1988     for $cpan_file (sort keys %dist) {
1989         $CPAN::Frontend->myprint("  CPAN: Recompiling $cpan_file\n\n");
1990         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1991         $pack->install;
1992         $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1993                            # stop a package from recompiling,
1994                            # e.g. IO-1.12 when we have perl5.003_10
1995     }
1996 }
1997
1998 #-> sub CPAN::Shell::scripts ;
1999 sub scripts {
2000     my($self, $arg) = @_;
2001     $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");
2002
2003     for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) {
2004         unless ($CPAN::META->has_inst($req)) {
2005             $CPAN::Frontend->mywarn("  $req not available\n");
2006         }
2007     }
2008     my $p = HTML::LinkExtor->new();
2009     my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html";
2010     unless (-f $indexfile) {
2011         $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n");
2012     }
2013     $p->parse_file($indexfile);
2014     my @hrefs;
2015     my $qrarg;
2016     if ($arg =~ s|^/(.+)/$|$1|) {
2017         $qrarg = eval 'qr/$arg/'; # hide construct from 5.004
2018     }
2019     for my $l ($p->links) {
2020         my $tag = shift @$l;
2021         next unless $tag eq "a";
2022         my %att = @$l;
2023         my $href = $att{href};
2024         next unless $href =~ s|^\.\./authors/id/./../||;
2025         if ($arg) {
2026             if ($qrarg) {
2027                 if ($href =~ $qrarg) {
2028                     push @hrefs, $href;
2029                 }
2030             } else {
2031                 if ($href =~ /\Q$arg\E/) {
2032                     push @hrefs, $href;
2033                 }
2034             }
2035         } else {
2036             push @hrefs, $href;
2037         }
2038     }
2039     # now filter for the latest version if there is more than one of a name
2040     my %stems;
2041     for (sort @hrefs) {
2042         my $href = $_;
2043         s/-v?\d.*//;
2044         my $stem = $_;
2045         $stems{$stem} ||= [];
2046         push @{$stems{$stem}}, $href;
2047     }
2048     for (sort keys %stems) {
2049         my $highest;
2050         if (@{$stems{$_}} > 1) {
2051             $highest = List::Util::reduce {
2052                 Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b
2053               } @{$stems{$_}};
2054         } else {
2055             $highest = $stems{$_}[0];
2056         }
2057         $CPAN::Frontend->myprint("$highest\n");
2058     }
2059 }
2060
2061 #-> sub CPAN::Shell::report ;
2062 sub report {
2063     my($self,@args) = @_;
2064     unless ($CPAN::META->has_inst("CPAN::Reporter")) {
2065         $CPAN::Frontend->mydie("CPAN::Reporter not installed; cannot continue");
2066     }
2067     local $CPAN::Config->{test_report} = 1;
2068     $self->force("test",@args); # force is there so that the test be
2069                                 # re-run (as documented)
2070 }
2071
2072 #-> sub CPAN::Shell::install_tested
2073 sub install_tested {
2074     my($self,@some) = @_;
2075     $CPAN::Frontend->mywarn("install_tested() requires no arguments.\n"),
2076         return if @some;
2077     CPAN::Index->reload;
2078
2079     for my $d (%{$CPAN::META->{readwrite}{'CPAN::Distribution'}}) {
2080         my $do = CPAN::Shell->expandany($d);
2081         next unless $do->{build_dir};
2082         push @some, $do;
2083     }
2084
2085     $CPAN::Frontend->mywarn("No tested distributions found.\n"),
2086         return unless @some;
2087
2088     @some = grep { $_->{make_test} && ! $_->{make_test}->failed } @some;
2089     $CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"),
2090         return unless @some;
2091
2092     @some = grep { not $_->uptodate } @some;
2093     $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"),
2094         return unless @some;
2095
2096     CPAN->debug("some[@some]");
2097     for my $d (@some) {
2098         my $id = $d->can("pretty_id") ? $d->pretty_id : $d->id;
2099         $CPAN::Frontend->myprint("install_tested: Running for $id\n");
2100         $CPAN::Frontend->sleep(1);
2101         $self->install($d);
2102     }
2103 }
2104
2105 #-> sub CPAN::Shell::upgrade ;
2106 sub upgrade {
2107     my($self,@args) = @_;
2108     $self->install($self->r(@args));
2109 }
2110
2111 #-> sub CPAN::Shell::_u_r_common ;
2112 sub _u_r_common {
2113     my($self) = shift @_;
2114     my($what) = shift @_;
2115     CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
2116     Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
2117           $what && $what =~ /^[aru]$/;
2118     my(@args) = @_;
2119     @args = '/./' unless @args;
2120     my(@result,$module,%seen,%need,$headerdone,
2121        $version_undefs,$version_zeroes);
2122     $version_undefs = $version_zeroes = 0;
2123     my $sprintf = "%s%-25s%s %9s %9s  %s\n";
2124     my @expand = $self->expand('Module',@args);
2125     my $expand = scalar @expand;
2126     if (0) { # Looks like noise to me, was very useful for debugging
2127              # for metadata cache
2128         $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
2129     }
2130   MODULE: for $module (@expand) {
2131         my $file  = $module->cpan_file;
2132         next MODULE unless defined $file; # ??
2133         $file =~ s|^./../||;
2134         my($latest) = $module->cpan_version;
2135         my($inst_file) = $module->inst_file;
2136         my($have);
2137         return if $CPAN::Signal;
2138         if ($inst_file){
2139             if ($what eq "a") {
2140                 $have = $module->inst_version;
2141             } elsif ($what eq "r") {
2142                 $have = $module->inst_version;
2143                 local($^W) = 0;
2144                 if ($have eq "undef"){
2145                     $version_undefs++;
2146                 } elsif ($have == 0){
2147                     $version_zeroes++;
2148                 }
2149                 next MODULE unless CPAN::Version->vgt($latest, $have);
2150 # to be pedantic we should probably say:
2151 #    && !($have eq "undef" && $latest ne "undef" && $latest gt "");
2152 # to catch the case where CPAN has a version 0 and we have a version undef
2153             } elsif ($what eq "u") {
2154                 next MODULE;
2155             }
2156         } else {
2157             if ($what eq "a") {
2158                 next MODULE;
2159             } elsif ($what eq "r") {
2160                 next MODULE;
2161             } elsif ($what eq "u") {
2162                 $have = "-";
2163             }
2164         }
2165         return if $CPAN::Signal; # this is sometimes lengthy
2166         $seen{$file} ||= 0;
2167         if ($what eq "a") {
2168             push @result, sprintf "%s %s\n", $module->id, $have;
2169         } elsif ($what eq "r") {
2170             push @result, $module->id;
2171             next MODULE if $seen{$file}++;
2172         } elsif ($what eq "u") {
2173             push @result, $module->id;
2174             next MODULE if $seen{$file}++;
2175             next MODULE if $file =~ /^Contact/;
2176         }
2177         unless ($headerdone++){
2178             $CPAN::Frontend->myprint("\n");
2179             $CPAN::Frontend->myprint(sprintf(
2180                                              $sprintf,
2181                                              "",
2182                                              "Package namespace",
2183                                              "",
2184                                              "installed",
2185                                              "latest",
2186                                              "in CPAN file"
2187                                             ));
2188         }
2189         my $color_on = "";
2190         my $color_off = "";
2191         if (
2192             $COLOR_REGISTERED
2193             &&
2194             $CPAN::META->has_inst("Term::ANSIColor")
2195             &&
2196             $module->description
2197            ) {
2198             $color_on = Term::ANSIColor::color("green");
2199             $color_off = Term::ANSIColor::color("reset");
2200         }
2201         $CPAN::Frontend->myprint(sprintf $sprintf,
2202                                  $color_on,
2203                                  $module->id,
2204                                  $color_off,
2205                                  $have,
2206                                  $latest,
2207                                  $file);
2208         $need{$module->id}++;
2209     }
2210     unless (%need) {
2211         if ($what eq "u") {
2212             $CPAN::Frontend->myprint("No modules found for @args\n");
2213         } elsif ($what eq "r") {
2214             $CPAN::Frontend->myprint("All modules are up to date for @args\n");
2215         }
2216     }
2217     if ($what eq "r") {
2218         if ($version_zeroes) {
2219             my $s_has = $version_zeroes > 1 ? "s have" : " has";
2220             $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
2221                 qq{a version number of 0\n});
2222         }
2223         if ($version_undefs) {
2224             my $s_has = $version_undefs > 1 ? "s have" : " has";
2225             $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
2226                 qq{parseable version number\n});
2227         }
2228     }
2229     @result;
2230 }
2231
2232 #-> sub CPAN::Shell::r ;
2233 sub r {
2234     shift->_u_r_common("r",@_);
2235 }
2236
2237 #-> sub CPAN::Shell::u ;
2238 sub u {
2239     shift->_u_r_common("u",@_);
2240 }
2241
2242 #-> sub CPAN::Shell::failed ;
2243 sub failed {
2244     my($self,$only_id,$silent) = @_;
2245     my @failed;
2246   DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
2247         my $failed = "";
2248       NAY: for my $nosayer ( # order matters!
2249                             "unwrapped",
2250                             "writemakefile",
2251                             "signature_verify",
2252                             "make",
2253                             "make_test",
2254                             "install",
2255                             "make_clean",
2256                            ) {
2257             next unless exists $d->{$nosayer};
2258             next unless defined $d->{$nosayer};
2259             next unless (
2260                          UNIVERSAL::can($d->{$nosayer},"failed") ?
2261                          $d->{$nosayer}->failed :
2262                          $d->{$nosayer} =~ /^NO/
2263                         );
2264             next NAY if $only_id && $only_id != (
2265                                                  UNIVERSAL::can($d->{$nosayer},"commandid")
2266                                                  ?
2267                                                  $d->{$nosayer}->commandid
2268                                                  :
2269                                                  $CPAN::CurrentCommandId
2270                                                 );
2271             $failed = $nosayer;
2272             last;
2273         }
2274         next DIST unless $failed;
2275         my $id = $d->id;
2276         $id =~ s|^./../||;
2277         #$print .= sprintf(
2278         #                  "  %-45s: %s %s\n",
2279         push @failed,
2280             (
2281              UNIVERSAL::can($d->{$failed},"failed") ?
2282              [
2283               $d->{$failed}->commandid,
2284               $id,
2285               $failed,
2286               $d->{$failed}->text,
2287               $d->{$failed}{TIME}||0,
2288              ] :
2289              [
2290               1,
2291               $id,
2292               $failed,
2293               $d->{$failed},
2294               0,
2295              ]
2296             );
2297     }
2298     my $scope;
2299     if ($only_id) {
2300         $scope = "this command";
2301     } elsif ($CPAN::Index::HAVE_REANIMATED) {
2302         $scope = "this or a previous session";
2303         # it might be nice to have a section for previous session and
2304         # a second for this
2305     } else {
2306         $scope = "this session";
2307     }
2308     if (@failed) {
2309         my $print;
2310         my $debug = 0;
2311         if ($debug) {
2312             $print = join "",
2313                 map { sprintf "%5d %-45s: %s %s\n", @$_ }
2314                     sort { $a->[0] <=> $b->[0] } @failed;
2315         } else {
2316             $print = join "",
2317                 map { sprintf " %-45s: %s %s\n", @$_[1..3] }
2318                     sort {
2319                         $a->[0] <=> $b->[0]
2320                             ||
2321                                 $a->[4] <=> $b->[4]
2322                        } @failed;
2323         }
2324         $CPAN::Frontend->myprint("Failed during $scope:\n$print");
2325     } elsif (!$only_id || !$silent) {
2326         $CPAN::Frontend->myprint("Nothing failed in $scope\n");
2327     }
2328 }
2329
2330 # XXX intentionally undocumented because completely bogus, unportable,
2331 # useless, etc.
2332
2333 #-> sub CPAN::Shell::status ;
2334 sub status {
2335     my($self) = @_;
2336     require Devel::Size;
2337     my $ps = FileHandle->new;
2338     open $ps, "/proc/$$/status";
2339     my $vm = 0;
2340     while (<$ps>) {
2341         next unless /VmSize:\s+(\d+)/;
2342         $vm = $1;
2343         last;
2344     }
2345     $CPAN::Frontend->mywarn(sprintf(
2346                                     "%-27s %6d\n%-27s %6d\n",
2347                                     "vm",
2348                                     $vm,
2349                                     "CPAN::META",
2350                                     Devel::Size::total_size($CPAN::META)/1024,
2351                                    ));
2352     for my $k (sort keys %$CPAN::META) {
2353         next unless substr($k,0,4) eq "read";
2354         warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
2355         for my $k2 (sort keys %{$CPAN::META->{$k}}) {
2356             warn sprintf "  %-25s %6d (keys: %6d)\n",
2357                 $k2,
2358                     Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
2359                           scalar keys %{$CPAN::META->{$k}{$k2}};
2360         }
2361     }
2362 }
2363
2364 #-> sub CPAN::Shell::autobundle ;
2365 sub autobundle {
2366     my($self) = shift;
2367     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
2368     my(@bundle) = $self->_u_r_common("a",@_);
2369     my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
2370     File::Path::mkpath($todir);
2371     unless (-d $todir) {
2372         $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
2373         return;
2374     }
2375     my($y,$m,$d) =  (localtime)[5,4,3];
2376     $y+=1900;
2377     $m++;
2378     my($c) = 0;
2379     my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
2380     my($to) = File::Spec->catfile($todir,"$me.pm");
2381     while (-f $to) {
2382         $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
2383         $to = File::Spec->catfile($todir,"$me.pm");
2384     }
2385     my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
2386     $fh->print(
2387                "package Bundle::$me;\n\n",
2388                "\$VERSION = '0.01';\n\n",
2389                "1;\n\n",
2390                "__END__\n\n",
2391                "=head1 NAME\n\n",
2392                "Bundle::$me - Snapshot of installation on ",
2393                $Config::Config{'myhostname'},
2394                " on ",
2395                scalar(localtime),
2396                "\n\n=head1 SYNOPSIS\n\n",
2397                "perl -MCPAN -e 'install Bundle::$me'\n\n",
2398                "=head1 CONTENTS\n\n",
2399                join("\n", @bundle),
2400                "\n\n=head1 CONFIGURATION\n\n",
2401                Config->myconfig,
2402                "\n\n=head1 AUTHOR\n\n",
2403                "This Bundle has been generated automatically ",
2404                "by the autobundle routine in CPAN.pm.\n",
2405               );
2406     $fh->close;
2407     $CPAN::Frontend->myprint("\nWrote bundle file
2408     $to\n\n");
2409 }
2410
2411 #-> sub CPAN::Shell::expandany ;
2412 sub expandany {
2413     my($self,$s) = @_;
2414     CPAN->debug("s[$s]") if $CPAN::DEBUG;
2415     if ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory
2416         $s = CPAN::Distribution->normalize($s);
2417         return $CPAN::META->instance('CPAN::Distribution',$s);
2418         # Distributions spring into existence, not expand
2419     } elsif ($s =~ m|^Bundle::|) {
2420         $self->local_bundles; # scanning so late for bundles seems
2421                               # both attractive and crumpy: always
2422                               # current state but easy to forget
2423                               # somewhere
2424         return $self->expand('Bundle',$s);
2425     } else {
2426         return $self->expand('Module',$s)
2427             if $CPAN::META->exists('CPAN::Module',$s);
2428     }
2429     return;
2430 }
2431
2432 #-> sub CPAN::Shell::expand ;
2433 sub expand {
2434     my $self = shift;
2435     my($type,@args) = @_;
2436     CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
2437     my $class = "CPAN::$type";
2438     my $methods = ['id'];
2439     for my $meth (qw(name)) {
2440         next unless $class->can($meth);
2441         push @$methods, $meth;
2442     }
2443     $self->expand_by_method($class,$methods,@args);
2444 }
2445
2446 #-> sub CPAN::Shell::expand_by_method ;
2447 sub expand_by_method {
2448     my $self = shift;
2449     my($class,$methods,@args) = @_;
2450     my($arg,@m);
2451     for $arg (@args) {
2452         my($regex,$command);
2453         if ($arg =~ m|^/(.*)/$|) {
2454             $regex = $1;
2455         } elsif ($arg =~ m/=/) {
2456             $command = 1;
2457         }
2458         my $obj;
2459         CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
2460                     $class,
2461                     defined $regex ? $regex : "UNDEFINED",
2462                     defined $command ? $command : "UNDEFINED",
2463                    ) if $CPAN::DEBUG;
2464         if (defined $regex) {
2465             if (CPAN::_sqlite_running) {
2466                 $CPAN::SQLite->search($class, $regex);
2467             }
2468             for $obj (
2469                       $CPAN::META->all_objects($class)
2470                      ) {
2471                 unless ($obj->id){
2472                     # BUG, we got an empty object somewhere
2473                     require Data::Dumper;
2474                     CPAN->debug(sprintf(
2475                                         "Bug in CPAN: Empty id on obj[%s][%s]",
2476                                         $obj,
2477                                         Data::Dumper::Dumper($obj)
2478                                        )) if $CPAN::DEBUG;
2479                     next;
2480                 }
2481                 for my $method (@$methods) {
2482                     my $match = eval {$obj->$method() =~ /$regex/i};
2483                     if ($@) {
2484                         my($err) = $@ =~ /^(.+) at .+? line \d+\.$/;
2485                         $err ||= $@; # if we were too restrictive above
2486                         $CPAN::Frontend->mydie("$err\n");
2487                     } elsif ($match) {
2488                         push @m, $obj;
2489                         last;
2490                     }
2491                 }
2492             }
2493         } elsif ($command) {
2494             die "equal sign in command disabled (immature interface), ".
2495                 "you can set
2496  ! \$CPAN::Shell::ADVANCED_QUERY=1
2497 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
2498 that may go away anytime.\n"
2499                     unless $ADVANCED_QUERY;
2500             my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
2501             my($matchcrit) = $criterion =~ m/^~(.+)/;
2502             for my $self (
2503                           sort
2504                           {$a->id cmp $b->id}
2505                           $CPAN::META->all_objects($class)
2506                          ) {
2507                 my $lhs = $self->$method() or next; # () for 5.00503
2508                 if ($matchcrit) {
2509                     push @m, $self if $lhs =~ m/$matchcrit/;
2510                 } else {
2511                     push @m, $self if $lhs eq $criterion;
2512                 }
2513             }
2514         } else {
2515             my($xarg) = $arg;
2516             if ( $class eq 'CPAN::Bundle' ) {
2517                 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
2518             } elsif ($class eq "CPAN::Distribution") {
2519                 $xarg = CPAN::Distribution->normalize($arg);
2520             } else {
2521                 $xarg =~ s/:+/::/g;
2522             }
2523             if ($CPAN::META->exists($class,$xarg)) {
2524                 $obj = $CPAN::META->instance($class,$xarg);
2525             } elsif ($CPAN::META->exists($class,$arg)) {
2526                 $obj = $CPAN::META->instance($class,$arg);
2527             } else {
2528                 next;
2529             }
2530             push @m, $obj;
2531         }
2532     }
2533     @m = sort {$a->id cmp $b->id} @m;
2534     if ( $CPAN::DEBUG ) {
2535         my $wantarray = wantarray;
2536         my $join_m = join ",", map {$_->id} @m;
2537         $self->debug("wantarray[$wantarray]join_m[$join_m]");
2538     }
2539     return wantarray ? @m : $m[0];
2540 }
2541
2542 #-> sub CPAN::Shell::format_result ;
2543 sub format_result {
2544     my($self) = shift;
2545     my($type,@args) = @_;
2546     @args = '/./' unless @args;
2547     my(@result) = $self->expand($type,@args);
2548     my $result = @result == 1 ?
2549         $result[0]->as_string :
2550             @result == 0 ?
2551                 "No objects of type $type found for argument @args\n" :
2552                     join("",
2553                          (map {$_->as_glimpse} @result),
2554                          scalar @result, " items found\n",
2555                         );
2556     $result;
2557 }
2558
2559 #-> sub CPAN::Shell::report_fh ;
2560 {
2561     my $installation_report_fh;
2562     my $previously_noticed = 0;
2563
2564     sub report_fh {
2565         return $installation_report_fh if $installation_report_fh;
2566         if ($CPAN::META->has_inst("File::Temp")) {
2567             $installation_report_fh
2568                 = File::Temp->new(
2569                                   template => 'cpan_install_XXXX',
2570                                   suffix   => '.txt',
2571                                   unlink   => 0,
2572                                  );
2573         }
2574         unless ( $installation_report_fh ) {
2575             warn("Couldn't open installation report file; " .
2576                  "no report file will be generated."
2577                 ) unless $previously_noticed++;
2578         }
2579     }
2580 }
2581
2582
2583 # The only reason for this method is currently to have a reliable
2584 # debugging utility that reveals which output is going through which
2585 # channel. No, I don't like the colors ;-)
2586
2587 # to turn colordebugging on, write
2588 # cpan> o conf colorize_output 1
2589
2590 #-> sub CPAN::Shell::print_ornamented ;
2591 {
2592     my $print_ornamented_have_warned = 0;
2593     sub colorize_output {
2594         my $colorize_output = $CPAN::Config->{colorize_output};
2595         if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
2596             unless ($print_ornamented_have_warned++) {
2597                 # no myprint/mywarn within myprint/mywarn!
2598                 warn "Colorize_output is set to true but Term::ANSIColor is not
2599 installed. To activate colorized output, please install Term::ANSIColor.\n\n";
2600             }
2601             $colorize_output = 0;
2602         }
2603         return $colorize_output;
2604     }
2605 }
2606
2607
2608 #-> sub CPAN::Shell::print_ornamented ;
2609 sub print_ornamented {
2610     my($self,$what,$ornament) = @_;
2611     return unless defined $what;
2612
2613     local $| = 1; # Flush immediately
2614     if ( $CPAN::Be_Silent ) {
2615         print {report_fh()} $what;
2616         return;
2617     }
2618     my $swhat = "$what"; # stringify if it is an object
2619     if ($CPAN::Config->{term_is_latin}){
2620         # courtesy jhi:
2621         $swhat
2622             =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
2623     }
2624     if ($self->colorize_output) {
2625         if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
2626             # if you want to have this configurable, please file a bugreport
2627             $ornament = "black on_cyan";
2628         }
2629         my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
2630         if ($@) {
2631             print "Term::ANSIColor rejects color[$ornament]: $@\n
2632 Please choose a different color (Hint: try 'o conf init color.*')\n";
2633         }
2634         print $color_on,
2635             $swhat,
2636                 Term::ANSIColor::color("reset");
2637     } else {
2638         print $swhat;
2639     }
2640 }
2641
2642 #-> sub CPAN::Shell::myprint ;
2643
2644 # where is myprint/mywarn/Frontend/etc. documented? We need guidelines
2645 # where to use what! I think, we send everything to STDOUT and use
2646 # print for normal/good news and warn for news that need more
2647 # attention. Yes, this is our working contract for now.
2648 sub myprint {
2649     my($self,$what) = @_;
2650
2651     $self->print_ornamented($what, $CPAN::Config->{colorize_print}||'bold blue on_white');
2652 }
2653
2654 #-> sub CPAN::Shell::myexit ;
2655 sub myexit {
2656     my($self,$what) = @_;
2657     $self->myprint($what);
2658     exit;
2659 }
2660
2661 #-> sub CPAN::Shell::mywarn ;
2662 sub mywarn {
2663     my($self,$what) = @_;
2664     $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
2665 }
2666
2667 # only to be used for shell commands
2668 #-> sub CPAN::Shell::mydie ;
2669 sub mydie {
2670     my($self,$what) = @_;
2671     $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
2672
2673     # If it is the shell, we want that the following die to be silent,
2674     # but if it is not the shell, we would need a 'die $what'. We need
2675     # to take care that only shell commands use mydie. Is this
2676     # possible?
2677
2678     die "\n";
2679 }
2680
2681 # sub CPAN::Shell::colorable_makemaker_prompt ;
2682 sub colorable_makemaker_prompt {
2683     my($foo,$bar) = @_;
2684     if (CPAN::Shell->colorize_output) {
2685         my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
2686         my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
2687         print $color_on;
2688     }
2689     my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
2690     if (CPAN::Shell->colorize_output) {
2691         print Term::ANSIColor::color('reset');
2692     }
2693     return $ans;
2694 }
2695
2696 # use this only for unrecoverable errors!
2697 #-> sub CPAN::Shell::unrecoverable_error ;
2698 sub unrecoverable_error {
2699     my($self,$what) = @_;
2700     my @lines = split /\n/, $what;
2701     my $longest = 0;
2702     for my $l (@lines) {
2703         $longest = length $l if length $l > $longest;
2704     }
2705     $longest = 62 if $longest > 62;
2706     for my $l (@lines) {
2707         if ($l =~ /^\s*$/){
2708             $l = "\n";
2709             next;
2710         }
2711         $l = "==> $l";
2712         if (length $l < 66) {
2713             $l = pack "A66 A*", $l, "<==";
2714         }
2715         $l .= "\n";
2716     }
2717     unshift @lines, "\n";
2718     $self->mydie(join "", @lines);
2719 }
2720
2721 #-> sub CPAN::Shell::mysleep ;
2722 sub mysleep {
2723     my($self, $sleep) = @_;
2724     sleep $sleep;
2725 }
2726
2727 #-> sub CPAN::Shell::setup_output ;
2728 sub setup_output {
2729     return if -t STDOUT;
2730     my $odef = select STDERR;
2731     $| = 1;
2732     select STDOUT;
2733     $| = 1;
2734     select $odef;
2735 }
2736
2737 #-> sub CPAN::Shell::rematein ;
2738 # RE-adme||MA-ke||TE-st||IN-stall : nearly everything runs through here
2739 sub rematein {
2740     my $self = shift;
2741     my($meth,@some) = @_;
2742     my @pragma;
2743     while($meth =~ /^(force|notest)$/) {
2744         push @pragma, $meth;
2745         $meth = shift @some or
2746             $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
2747                                    "cannot continue");
2748     }
2749     setup_output();
2750     CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
2751
2752     # Here is the place to set "test_count" on all involved parties to
2753     # 0. We then can pass this counter on to the involved
2754     # distributions and those can refuse to test if test_count > X. In
2755     # the first stab at it we could use a 1 for "X".
2756
2757     # But when do I reset the distributions to start with 0 again?
2758     # Jost suggested to have a random or cycling interaction ID that
2759     # we pass through. But the ID is something that is just left lying
2760     # around in addition to the counter, so I'd prefer to set the
2761     # counter to 0 now, and repeat at the end of the loop. But what
2762     # about dependencies? They appear later and are not reset, they
2763     # enter the queue but not its copy. How do they get a sensible
2764     # test_count?
2765
2766     # construct the queue
2767     my($s,@s,@qcopy);
2768   STHING: foreach $s (@some) {
2769         my $obj;
2770         if (ref $s) {
2771             CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
2772             $obj = $s;
2773         } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
2774         } elsif ($s =~ m|^/|) { # looks like a regexp
2775             if (substr($s,-1,1) eq ".") {
2776                 $obj = CPAN::Shell->expandany($s);
2777             } else {
2778                 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
2779                                         "not supported.\nRejecting argument '$s'\n");
2780                 $CPAN::Frontend->mysleep(2);
2781                 next;
2782             }
2783         } elsif ($meth eq "ls") {
2784             $self->globls($s,\@pragma);
2785             next STHING;
2786         } else {
2787             CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
2788             $obj = CPAN::Shell->expandany($s);
2789         }
2790         if (0) {
2791         } elsif (ref $obj) {
2792             $obj->color_cmd_tmps(0,1);
2793             CPAN::Queue->new(qmod => $obj->id, reqtype => "c");
2794             push @qcopy, $obj;
2795         } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
2796             $obj = $CPAN::META->instance('CPAN::Author',uc($s));
2797             if ($meth =~ /^(dump|ls)$/) {
2798                 $obj->$meth();
2799             } else {
2800                 $CPAN::Frontend->mywarn(
2801                                         join "",
2802                                         "Don't be silly, you can't $meth ",
2803                                         $obj->fullname,
2804                                         " ;-)\n"
2805                                        );
2806                 $CPAN::Frontend->mysleep(2);
2807             }
2808         } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
2809             CPAN::InfoObj->dump($s);
2810         } else {
2811             $CPAN::Frontend
2812                 ->mywarn(qq{Warning: Cannot $meth $s, }.
2813                           qq{don't know what it is.
2814 Try the command
2815
2816     i /$s/
2817
2818 to find objects with matching identifiers.
2819 });
2820             $CPAN::Frontend->mysleep(2);
2821         }
2822     }
2823
2824     # queuerunner (please be warned: when I started to change the
2825     # queue to hold objects instead of names, I made one or two
2826     # mistakes and never found which. I reverted back instead)
2827     while (my $q = CPAN::Queue->first) {
2828         my $obj;
2829         my $s = $q->as_string;
2830         my $reqtype = $q->reqtype || "";
2831         $obj = CPAN::Shell->expandany($s);
2832         $obj->{reqtype} ||= "";
2833         {
2834             # force debugging because CPAN::SQLite somehow delivers us
2835             # an empty object;
2836
2837             # local $CPAN::DEBUG = 1024; # Shell; probably fixed now
2838
2839             CPAN->debug("s[$s]obj-reqtype[$obj->{reqtype}]".
2840                         "q-reqtype[$reqtype]") if $CPAN::DEBUG;
2841         }
2842         if ($obj->{reqtype}) {
2843             if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
2844                 $obj->{reqtype} = $reqtype;
2845                 if (
2846                     exists $obj->{install}
2847                     &&
2848                     (
2849                      UNIVERSAL::can($obj->{install},"failed") ?
2850                      $obj->{install}->failed :
2851                      $obj->{install} =~ /^NO/
2852                     )
2853                    ) {
2854                     delete $obj->{install};
2855                     $CPAN::Frontend->mywarn
2856                         ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
2857                 }
2858             }
2859         } else {
2860             $obj->{reqtype} = $reqtype;
2861         }
2862
2863         for my $pragma (@pragma) {
2864             if ($pragma
2865                 &&
2866                 $obj->can($pragma)){
2867                 $obj->$pragma($meth);
2868             }
2869         }
2870         if (UNIVERSAL::can($obj, 'called_for')) {
2871             $obj->called_for($s);
2872         }
2873         CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
2874                     qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
2875
2876         push @qcopy, $obj;
2877         if (! UNIVERSAL::can($obj,$meth)) {
2878             # Must never happen
2879             my $serialized = "";
2880             if (0) {
2881             } elsif ($CPAN::META->has_inst("YAML::Syck")) {
2882                 $serialized = YAML::Syck::Dump($obj);
2883             } elsif ($CPAN::META->has_inst("YAML")) {
2884                 $serialized = YAML::Dump($obj);
2885             } elsif ($CPAN::META->has_inst("Data::Dumper")) {
2886                 $serialized = Data::Dumper::Dumper($obj);
2887             } else {
2888                 require overload;
2889                 $serialized = overload::StrVal($obj);
2890             }
2891             $CPAN::Frontend->mydie("Panic: obj[$serialized] cannot meth[$meth]");
2892         } elsif ($obj->$meth()){
2893             CPAN::Queue->delete($s);
2894         } else {
2895             CPAN->debug("failed");
2896         }
2897
2898         $obj->undelay;
2899         for my $pragma (@pragma) {
2900             my $unpragma = "un$pragma";
2901             if ($obj->can($unpragma)) {
2902                 $obj->$unpragma();
2903             }
2904         }
2905         CPAN::Queue->delete_first($s);
2906     }
2907     for my $obj (@qcopy) {
2908         $obj->color_cmd_tmps(0,0);
2909     }
2910 }
2911
2912 #-> sub CPAN::Shell::recent ;
2913 sub recent {
2914   my($self) = @_;
2915
2916   CPAN::Distribution::_display_url( $self, $CPAN::Defaultrecent );
2917   return;
2918 }
2919
2920 {
2921     # set up the dispatching methods
2922     no strict "refs";
2923     for my $command (qw(
2924                         clean
2925                         cvs_import
2926                         dump
2927                         force
2928                         get
2929                         install
2930                         look
2931                         ls
2932                         make
2933                         notest
2934                         perldoc
2935                         readme
2936                         test
2937                        )) {
2938         *$command = sub { shift->rematein($command, @_); };
2939     }
2940 }
2941
2942 package CPAN::LWP::UserAgent;
2943 use strict;
2944
2945 sub config {
2946     return if $SETUPDONE;
2947     if ($CPAN::META->has_usable('LWP::UserAgent')) {
2948         require LWP::UserAgent;
2949         @ISA = qw(Exporter LWP::UserAgent);
2950         $SETUPDONE++;
2951     } else {
2952         $CPAN::Frontend->mywarn("  LWP::UserAgent not available\n");
2953     }
2954 }
2955
2956 sub get_basic_credentials {
2957     my($self, $realm, $uri, $proxy) = @_;
2958     if ($USER && $PASSWD) {
2959         return ($USER, $PASSWD);
2960     }
2961     if ( $proxy ) {
2962         ($USER,$PASSWD) = $self->get_proxy_credentials();
2963     } else {
2964         ($USER,$PASSWD) = $self->get_non_proxy_credentials();
2965     }
2966     return($USER,$PASSWD);
2967 }
2968
2969 sub get_proxy_credentials {
2970     my $self = shift;
2971     my ($user, $password);
2972     if ( defined $CPAN::Config->{proxy_user} &&
2973          defined $CPAN::Config->{proxy_pass}) {
2974         $user = $CPAN::Config->{proxy_user};
2975         $password = $CPAN::Config->{proxy_pass};
2976         return ($user, $password);
2977     }
2978     my $username_prompt = "\nProxy authentication needed!
2979  (Note: to permanently configure username and password run
2980    o conf proxy_user your_username
2981    o conf proxy_pass your_password
2982      )\nUsername:";
2983     ($user, $password) =
2984         _get_username_and_password_from_user($username_prompt);
2985     return ($user,$password);
2986 }
2987
2988 sub get_non_proxy_credentials {
2989     my $self = shift;
2990     my ($user,$password);
2991     if ( defined $CPAN::Config->{username} &&
2992          defined $CPAN::Config->{password}) {
2993         $user = $CPAN::Config->{username};
2994         $password = $CPAN::Config->{password};
2995         return ($user, $password);
2996     }
2997     my $username_prompt = "\nAuthentication needed!
2998      (Note: to permanently configure username and password run
2999        o conf username your_username
3000        o conf password your_password
3001      )\nUsername:";
3002
3003     ($user, $password) =
3004         _get_username_and_password_from_user($username_prompt);
3005     return ($user,$password);
3006 }
3007
3008 sub _get_username_and_password_from_user {
3009     my $username_message = shift;
3010     my ($username,$password);
3011
3012     ExtUtils::MakeMaker->import(qw(prompt));
3013     $username = prompt($username_message);
3014         if ($CPAN::META->has_inst("Term::ReadKey")) {
3015             Term::ReadKey::ReadMode("noecho");
3016         }
3017     else {
3018         $CPAN::Frontend->mywarn(
3019             "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"
3020         );
3021     }
3022     $password = prompt("Password:");
3023
3024         if ($CPAN::META->has_inst("Term::ReadKey")) {
3025             Term::ReadKey::ReadMode("restore");
3026         }
3027         $CPAN::Frontend->myprint("\n\n");
3028     return ($username,$password);
3029 }
3030
3031 # mirror(): Its purpose is to deal with proxy authentication. When we
3032 # call SUPER::mirror, we relly call the mirror method in
3033 # LWP::UserAgent. LWP::UserAgent will then call
3034 # $self->get_basic_credentials or some equivalent and this will be
3035 # $self->dispatched to our own get_basic_credentials method.
3036
3037 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3038
3039 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3040 # although we have gone through our get_basic_credentials, the proxy
3041 # server refuses to connect. This could be a case where the username or
3042 # password has changed in the meantime, so I'm trying once again without
3043 # $USER and $PASSWD to give the get_basic_credentials routine another
3044 # chance to set $USER and $PASSWD.
3045
3046 # mirror(): Its purpose is to deal with proxy authentication. When we
3047 # call SUPER::mirror, we relly call the mirror method in
3048 # LWP::UserAgent. LWP::UserAgent will then call
3049 # $self->get_basic_credentials or some equivalent and this will be
3050 # $self->dispatched to our own get_basic_credentials method.
3051
3052 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3053
3054 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3055 # although we have gone through our get_basic_credentials, the proxy
3056 # server refuses to connect. This could be a case where the username or
3057 # password has changed in the meantime, so I'm trying once again without
3058 # $USER and $PASSWD to give the get_basic_credentials routine another
3059 # chance to set $USER and $PASSWD.
3060
3061 sub mirror {
3062     my($self,$url,$aslocal) = @_;
3063     my $result = $self->SUPER::mirror($url,$aslocal);
3064     if ($result->code == 407) {
3065         undef $USER;
3066         undef $PASSWD;
3067         $result = $self->SUPER::mirror($url,$aslocal);
3068     }
3069     $result;
3070 }
3071
3072 package CPAN::FTP;
3073 use strict;
3074
3075 #-> sub CPAN::FTP::ftp_statistics
3076 # if they want to rewrite, they need to pass in a filehandle
3077 sub _ftp_statistics {
3078     my($self,$fh) = @_;
3079     my $locktype = $fh ? LOCK_EX : LOCK_SH;
3080     $fh ||= FileHandle->new;
3081     my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3082     open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!");
3083     my $sleep = 1;
3084     my $waitstart;
3085     while (!flock $fh, $locktype|LOCK_NB) {
3086         $waitstart ||= localtime();
3087         if ($sleep>3) {
3088             $CPAN::Frontend->mywarn("Waiting for a read lock on '$file' (since $waitstart)\n");
3089         }
3090         $CPAN::Frontend->mysleep($sleep);
3091         if ($sleep <= 3) {
3092             $sleep+=0.33;
3093         } elsif ($sleep <=6) {
3094             $sleep+=0.11;
3095         }
3096     }
3097     my $stats = CPAN->_yaml_loadfile($file);
3098     return $stats->[0];
3099 }
3100
3101 #-> sub CPAN::FTP::_mytime
3102 sub _mytime () {
3103     if (CPAN->has_inst("Time::HiRes")) {
3104         return Time::HiRes::time();
3105     } else {
3106         return time;
3107     }
3108 }
3109
3110 #-> sub CPAN::FTP::_new_stats
3111 sub _new_stats {
3112     my($self,$file) = @_;
3113     my $ret = {
3114                file => $file,
3115                attempts => [],
3116                start => _mytime,
3117               };
3118     $ret;
3119 }
3120
3121 #-> sub CPAN::FTP::_add_to_statistics
3122 sub _add_to_statistics {
3123     my($self,$stats) = @_;
3124     my $yaml_module = $self->CPAN::_yaml_module;
3125     if ($CPAN::META->has_inst($yaml_module)) {
3126         $stats->{thesiteurl} = $ThesiteURL;
3127         if (CPAN->has_inst("Time::HiRes")) {
3128             $stats->{end} = Time::HiRes::time();
3129         } else {
3130             $stats->{end} = time;
3131         }
3132         my $fh = FileHandle->new;
3133         my $fullstats = $self->_ftp_statistics($fh);
3134         $fullstats->{history} ||= [];
3135         my @debug = scalar @{$fullstats->{history}};
3136         push @{$fullstats->{history}}, $stats;
3137         my $time = time;
3138         shift @{$fullstats->{history}}
3139             while $time - $fullstats->{history}[0]{start} > 30*86400; # one month too much?
3140         push @debug, scalar @{$fullstats->{history}};
3141         push @debug, scalar localtime($fullstats->{history}[0]{start});
3142         {
3143             # local $CPAN::DEBUG = 512;
3144             CPAN->debug(sprintf("DEBUG history: before[%d]after[%d]oldest[%s]",
3145                                 @debug,
3146                                )) if $CPAN::DEBUG;
3147         }
3148         seek $fh, 0, 0;
3149         truncate $fh, 0;
3150         CPAN->_yaml_dumpfile($fh,$fullstats);
3151     }
3152 }
3153
3154 # if file is CHECKSUMS, suggest the place where we got the file to be
3155 # checked from, maybe only for young files?
3156 #-> sub CPAN::FTP::_recommend_url_for
3157 sub _recommend_url_for {
3158     my($self, $file) = @_;
3159     my $urllist = $self->_get_urllist;
3160     if ($file =~ s|/CHECKSUMS(.gz)?$||) {
3161         my $fullstats = $self->_ftp_statistics();
3162         my $history = $fullstats->{history} || [];
3163         while (my $last = pop @$history) {
3164             last if $last->{end} - time > 3600; # only young results are interesting
3165             next unless $last->{file}; # dirname of nothing dies!
3166             next unless $file eq File::Basename::dirname($last->{file});
3167             return $last->{thesiteurl};
3168         }
3169     }
3170     if ($CPAN::Config->{randomize_urllist}
3171         &&
3172         rand(1) < $CPAN::Config->{randomize_urllist}
3173        ) {
3174         $urllist->[int rand scalar @$urllist];
3175     } else {
3176         return ();
3177     }
3178 }
3179
3180 #-> sub CPAN::FTP::_get_urllist
3181 sub _get_urllist {
3182     my($self) = @_;
3183     $CPAN::Config->{urllist} ||= [];
3184     unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
3185         $CPAN::Frontend->mywarn("Malformed urllist; ignoring.  Configuration file corrupt?\n");
3186         $CPAN::Config->{urllist} = [];
3187     }
3188     my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}};
3189     for my $u (@urllist) {
3190         CPAN->debug("u[$u]") if $CPAN::DEBUG;
3191         if (UNIVERSAL::can($u,"text")) {
3192             $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
3193         } else {
3194             $u .= "/" unless substr($u,-1) eq "/";
3195             $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
3196         }
3197     }
3198     \@urllist;
3199 }
3200
3201 #-> sub CPAN::FTP::ftp_get ;
3202 sub ftp_get {
3203     my($class,$host,$dir,$file,$target) = @_;
3204     $class->debug(
3205                   qq[Going to fetch file [$file] from dir [$dir]
3206         on host [$host] as local [$target]\n]
3207                  ) if $CPAN::DEBUG;
3208     my $ftp = Net::FTP->new($host);
3209     unless ($ftp) {
3210         $CPAN::Frontend->mywarn("  Could not connect to host '$host' with Net::FTP\n");
3211         return;
3212     }
3213     return 0 unless defined $ftp;
3214     $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
3215     $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
3216     unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
3217         my $msg = $ftp->message;
3218         $CPAN::Frontend->mywarn("  Couldn't login on $host: $msg");
3219         return;
3220     }
3221     unless ( $ftp->cwd($dir) ){
3222         my $msg = $ftp->message;
3223         $CPAN::Frontend->mywarn("  Couldn't cwd $dir: $msg");
3224         return;
3225     }
3226     $ftp->binary;
3227     $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
3228     unless ( $ftp->get($file,$target) ){
3229         my $msg = $ftp->message;
3230         $CPAN::Frontend->mywarn("  Couldn't fetch $file from $host: $msg");
3231         return;
3232     }
3233     $ftp->quit; # it's ok if this fails
3234     return 1;
3235 }
3236
3237 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
3238
3239  # > *** /install/perl/live/lib/CPAN.pm-        Wed Sep 24 13:08:48 1997
3240  # > --- /tmp/cp        Wed Sep 24 13:26:40 1997
3241  # > ***************
3242  # > *** 1562,1567 ****
3243  # > --- 1562,1580 ----
3244  # >       return 1 if substr($url,0,4) eq "file";
3245  # >       return 1 unless $url =~ m|://([^/]+)|;
3246  # >       my $host = $1;
3247  # > +     my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
3248  # > +     if ($proxy) {
3249  # > +         $proxy =~ m|://([^/:]+)|;
3250  # > +         $proxy = $1;
3251  # > +         my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
3252  # > +         if ($noproxy) {
3253  # > +             if ($host !~ /$noproxy$/) {
3254  # > +                 $host = $proxy;
3255  # > +             }
3256  # > +         } else {
3257  # > +             $host = $proxy;
3258  # > +         }
3259  # > +     }
3260  # >       require Net::Ping;
3261  # >       return 1 unless $Net::Ping::VERSION >= 2;
3262  # >       my $p;
3263
3264
3265 #-> sub CPAN::FTP::localize ;
3266 sub localize {
3267     my($self,$file,$aslocal,$force) = @_;
3268     $force ||= 0;
3269     Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
3270         unless defined $aslocal;
3271     $self->debug("file[$file] aslocal[$aslocal] force[$force]")
3272         if $CPAN::DEBUG;
3273
3274     if ($^O eq 'MacOS') {
3275         # Comment by AK on 2000-09-03: Uniq short filenames would be
3276         # available in CHECKSUMS file
3277         my($name, $path) = File::Basename::fileparse($aslocal, '');
3278         if (length($name) > 31) {
3279             $name =~ s/(
3280                         \.(
3281                            readme(\.(gz|Z))? |
3282                            (tar\.)?(gz|Z) |
3283                            tgz |
3284                            zip |
3285                            pm\.(gz|Z)
3286                           )
3287                        )$//x;
3288             my $suf = $1;
3289             my $size = 31 - length($suf);
3290             while (length($name) > $size) {
3291                 chop $name;
3292             }
3293             $name .= $suf;
3294             $aslocal = File::Spec->catfile($path, $name);
3295         }
3296     }
3297
3298     if (-f $aslocal && -r _ && !($force & 1)){
3299         my $size;
3300         if ($size = -s $aslocal) {
3301             $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
3302             return $aslocal;
3303         } else {
3304             # empty file from a previous unsuccessful attempt to download it
3305             unlink $aslocal or
3306                 $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
3307                                        "could not remove.");
3308         }
3309     }
3310     my($maybe_restore) = 0;
3311     if (-f $aslocal){
3312         rename $aslocal, "$aslocal.bak$$";
3313         $maybe_restore++;
3314     }
3315
3316     my($aslocal_dir) = File::Basename::dirname($aslocal);
3317     File::Path::mkpath($aslocal_dir);
3318     $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
3319         qq{directory "$aslocal_dir".
3320     I\'ll continue, but if you encounter problems, they may be due
3321     to insufficient permissions.\n}) unless -w $aslocal_dir;
3322
3323     # Inheritance is not easier to manage than a few if/else branches
3324     if ($CPAN::META->has_usable('LWP::UserAgent')) {
3325         unless ($Ua) {
3326             CPAN::LWP::UserAgent->config;
3327             eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
3328             if ($@) {
3329                 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
3330                     if $CPAN::DEBUG;
3331             } else {
3332                 my($var);
3333                 $Ua->proxy('ftp',  $var)
3334                     if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
3335                 $Ua->proxy('http', $var)
3336                     if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
3337
3338
3339 # >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
3340 #
3341 #  > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
3342 #  > use ones that require basic autorization.
3343 #
3344 #  > Example of when I use it manually in my own stuff:
3345 #
3346 #  > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
3347 #  > $req->proxy_authorization_basic("username","password");
3348 #  > $res = $ua->request($req);
3349 #
3350
3351                 $Ua->no_proxy($var)
3352                     if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
3353             }
3354         }
3355     }
3356     for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
3357         $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
3358     }
3359
3360     # Try the list of urls for each single object. We keep a record
3361     # where we did get a file from
3362     my(@reordered,$last);
3363     my $ccurllist = $self->_get_urllist;
3364     $last = $#$ccurllist;
3365     if ($force & 2) { # local cpans probably out of date, don't reorder
3366         @reordered = (0..$last);
3367     } else {
3368         @reordered =
3369             sort {
3370                 (substr($ccurllist->[$b],0,4) eq "file")
3371                     <=>
3372                 (substr($ccurllist->[$a],0,4) eq "file")
3373                     or
3374                 defined($ThesiteURL)
3375                     and
3376                 ($ccurllist->[$b] eq $ThesiteURL)
3377                     <=>
3378                 ($ccurllist->[$a] eq $ThesiteURL)
3379             } 0..$last;
3380     }
3381     my(@levels);
3382     $Themethod ||= "";
3383     $self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG;
3384     if ($Themethod) {
3385         @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
3386     } else {
3387         @levels = qw/easy hard hardest/;
3388     }
3389     @levels = qw/easy/ if $^O eq 'MacOS';
3390     my($levelno);
3391     local $ENV{FTP_PASSIVE} =
3392         exists $CPAN::Config->{ftp_passive} ?
3393         $CPAN::Config->{ftp_passive} : 1;
3394     my $ret;
3395     my $stats = $self->_new_stats($file);
3396   LEVEL: for $levelno (0..$#levels) {
3397         my $level = $levels[$levelno];
3398         my $method = "host$level";
3399         my @host_seq = $level eq "easy" ?
3400             @reordered : 0..$last;  # reordered has CDROM up front
3401         my @urllist = map { $ccurllist->[$_] } @host_seq;
3402         for my $u (@CPAN::Defaultsites) {
3403             push @urllist, $u unless grep { $_ eq $u } @urllist;
3404         }
3405         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
3406         my $aslocal_tempfile = $aslocal . ".tmp" . $$;
3407         if (my $recommend = $self->_recommend_url_for($file)) {
3408             @urllist = grep { $_ ne $recommend } @urllist;
3409             unshift @urllist, $recommend;
3410         }
3411         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
3412         $ret = $self->$method(\@urllist,$file,$aslocal_tempfile,$stats);
3413         if ($ret) {
3414             CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG;
3415             if ($ret eq $aslocal_tempfile) {
3416                 # if we got it exactly as we asked for, only then we
3417                 # want to rename
3418                 rename $aslocal_tempfile, $aslocal
3419                     or $CPAN::Frontend->mydie("Error while trying to rename ".
3420                                               "'$ret' to '$aslocal': $!");
3421                 $ret = $aslocal;
3422             }
3423             $Themethod = $level;
3424             my $now = time;
3425             # utime $now, $now, $aslocal; # too bad, if we do that, we
3426                                           # might alter a local mirror
3427             $self->debug("level[$level]") if $CPAN::DEBUG;
3428             last LEVEL;
3429         } else {
3430             unlink $aslocal_tempfile;
3431             last if $CPAN::Signal; # need to cleanup
3432         }
3433     }
3434     if ($ret) {
3435         $stats->{filesize} = -s $ret;
3436     }
3437     $self->_add_to_statistics($stats);
3438     if ($ret) {
3439         unlink "$aslocal.bak$$";
3440         return $ret;
3441     }
3442     unless ($CPAN::Signal) {
3443         my(@mess);
3444         local $" = " ";
3445         if (@{$CPAN::Config->{urllist}}) {
3446             push @mess,
3447                 qq{Please check, if the URLs I found in your configuration file \(}.
3448                     join(", ", @{$CPAN::Config->{urllist}}).
3449                         qq{\) are valid.};
3450         } else {
3451             push @mess, qq{Your urllist is empty!};
3452         }
3453         push @mess, qq{The urllist can be edited.},
3454             qq{E.g. with 'o conf urllist push ftp://myurl/'};
3455         $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
3456         $CPAN::Frontend->mywarn("Could not fetch $file\n");
3457         $CPAN::Frontend->mysleep(2);
3458     }
3459     if ($maybe_restore) {
3460         rename "$aslocal.bak$$", $aslocal;
3461         $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
3462                                  $self->ls($aslocal));
3463         return $aslocal;
3464     }
3465     return;
3466 }
3467
3468 sub _set_attempt {
3469     my($self,$stats,$method,$url) = @_;
3470     push @{$stats->{attempts}}, {
3471                                  method => $method,
3472                                  start => _mytime,
3473                                  url => $url,
3474                                 };
3475 }
3476
3477 # package CPAN::FTP;
3478 sub hosteasy {
3479     my($self,$host_seq,$file,$aslocal,$stats) = @_;
3480     my($ro_url);
3481   HOSTEASY: for $ro_url (@$host_seq) {
3482         $self->_set_attempt($stats,"easy",$ro_url);
3483         my $url .= "$ro_url$file";
3484         $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
3485         if ($url =~ /^file:/) {
3486             my $l;
3487             if ($CPAN::META->has_inst('URI::URL')) {
3488                 my $u =  URI::URL->new($url);
3489                 $l = $u->path;
3490             } else { # works only on Unix, is poorly constructed, but
3491                 # hopefully better than nothing.
3492                 # RFC 1738 says fileurl BNF is
3493                 # fileurl = "file://" [ host | "localhost" ] "/" fpath
3494                 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
3495                 # the code
3496                 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
3497                 $l =~ s|^file:||;                   # assume they
3498                                                     # meant
3499                                                     # file://localhost
3500                 $l =~ s|^/||s
3501                     if ! -f $l && $l =~ m|^/\w:|;   # e.g. /P:
3502             }
3503             $self->debug("local file[$l]") if $CPAN::DEBUG;
3504             if ( -f $l && -r _) {
3505                 $ThesiteURL = $ro_url;
3506                 return $l;
3507             }
3508             if ($l =~ /(.+)\.gz$/) {
3509                 my $ungz = $1;
3510                 if ( -f $ungz && -r _) {
3511                     $ThesiteURL = $ro_url;
3512                     return $ungz;
3513                 }
3514             }
3515             # Maybe mirror has compressed it?
3516             if (-f "$l.gz") {
3517                 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
3518                 eval { CPAN::Tarzip->new("$l.gz")->gunzip($aslocal) };
3519                 if ( -f $aslocal) {
3520                     $ThesiteURL = $ro_url;
3521                     return $aslocal;
3522                 }
3523             }
3524         }
3525         $self->debug("it was not a file URL") if $CPAN::DEBUG;
3526         if ($CPAN::META->has_usable('LWP')) {
3527             $CPAN::Frontend->myprint("Fetching with LWP:
3528   $url
3529 ");
3530             unless ($Ua) {
3531                 CPAN::LWP::UserAgent->config;
3532                 eval { $Ua = CPAN::LWP::UserAgent->new; };
3533                 if ($@) {
3534                     $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
3535                 }
3536             }
3537             my $res = $Ua->mirror($url, $aslocal);
3538             if ($res->is_success) {
3539                 $ThesiteURL = $ro_url;
3540                 my $now = time;
3541                 utime $now, $now, $aslocal; # download time is more
3542                                             # important than upload
3543                                             # time
3544                 return $aslocal;
3545             } elsif ($url !~ /\.gz(?!\n)\Z/) {
3546                 my $gzurl = "$url.gz";
3547                 $CPAN::Frontend->myprint("Fetching with LWP:
3548   $gzurl
3549 ");
3550                 $res = $Ua->mirror($gzurl, "$aslocal.gz");
3551                 if ($res->is_success) {
3552                     if (eval {CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)}) {
3553                         $ThesiteURL = $ro_url;
3554                         return $aslocal;
3555                     }
3556                 }
3557             } else {
3558                 $CPAN::Frontend->myprint(sprintf(
3559                                                  "LWP failed with code[%s] message[%s]\n",
3560                                                  $res->code,
3561                                                  $res->message,
3562                                                 ));
3563                 # Alan Burlison informed me that in firewall environments
3564                 # Net::FTP can still succeed where LWP fails. So we do not
3565                 # skip Net::FTP anymore when LWP is available.
3566             }
3567         } else {
3568             $CPAN::Frontend->mywarn("  LWP not available\n");
3569         }
3570         return if $CPAN::Signal;
3571         if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3572             # that's the nice and easy way thanks to Graham
3573             $self->debug("recognized ftp") if $CPAN::DEBUG;
3574             my($host,$dir,$getfile) = ($1,$2,$3);
3575             if ($CPAN::META->has_usable('Net::FTP')) {
3576                 $dir =~ s|/+|/|g;
3577                 $CPAN::Frontend->myprint("Fetching with Net::FTP:
3578   $url
3579 ");
3580                 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
3581                              "aslocal[$aslocal]") if $CPAN::DEBUG;
3582                 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
3583                     $ThesiteURL = $ro_url;
3584                     return $aslocal;
3585                 }
3586                 if ($aslocal !~ /\.gz(?!\n)\Z/) {
3587                     my $gz = "$aslocal.gz";
3588                     $CPAN::Frontend->myprint("Fetching with Net::FTP
3589   $url.gz
3590 ");
3591                     if (CPAN::FTP->ftp_get($host,
3592                                            $dir,
3593                                            "$getfile.gz",
3594                                            $gz) &&
3595                         eval{CPAN::Tarzip->new($gz)->gunzip($aslocal)}
3596                        ){
3597                         $ThesiteURL = $ro_url;
3598                         return $aslocal;
3599                     }
3600                 }
3601                 # next HOSTEASY;
3602             } else {
3603                 CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG;
3604             }
3605         }
3606         if (
3607             UNIVERSAL::can($ro_url,"text")
3608             and
3609             $ro_url->{FROM} eq "USER"
3610            ){
3611             ##address #17973: default URLs should not try to override
3612             ##user-defined URLs just because LWP is not available
3613             my $ret = $self->hosthard([$ro_url],$file,$aslocal,$stats);
3614             return $ret if $ret;
3615         }
3616         return if $CPAN::Signal;
3617     }
3618 }
3619
3620 # package CPAN::FTP;
3621 sub hosthard {
3622   my($self,$host_seq,$file,$aslocal,$stats) = @_;
3623
3624   # Came back if Net::FTP couldn't establish connection (or
3625   # failed otherwise) Maybe they are behind a firewall, but they
3626   # gave us a socksified (or other) ftp program...
3627
3628   my($ro_url);
3629   my($devnull) = $CPAN::Config->{devnull} || "";
3630   # < /dev/null ";
3631   my($aslocal_dir) = File::Basename::dirname($aslocal);
3632   File::Path::mkpath($aslocal_dir);
3633   HOSTHARD: for $ro_url (@$host_seq) {
3634         $self->_set_attempt($stats,"hard",$ro_url);
3635         my $url = "$ro_url$file";
3636         my($proto,$host,$dir,$getfile);
3637
3638         # Courtesy Mark Conty mark_conty@cargill.com change from
3639         # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3640         # to
3641         if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
3642           # proto not yet used
3643           ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
3644         } else {
3645           next HOSTHARD; # who said, we could ftp anything except ftp?
3646         }
3647         next HOSTHARD if $proto eq "file"; # file URLs would have had
3648                                            # success above. Likely a bogus URL
3649
3650         $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
3651
3652         # Try the most capable first and leave ncftp* for last as it only
3653         # does FTP.
3654       DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
3655           my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
3656           next unless defined $funkyftp;
3657           next if $funkyftp =~ /^\s*$/;
3658
3659           my($asl_ungz, $asl_gz);
3660           ($asl_ungz = $aslocal) =~ s/\.gz//;
3661           $asl_gz = "$asl_ungz.gz";
3662
3663           my($src_switch) = "";
3664           my($chdir) = "";
3665           my($stdout_redir) = " > $asl_ungz";
3666           if ($f eq "lynx"){
3667             $src_switch = " -source";
3668           } elsif ($f eq "ncftp"){
3669             $src_switch = " -c";
3670           } elsif ($f eq "wget"){
3671             $src_switch = " -O $asl_ungz";
3672             $stdout_redir = "";
3673           } elsif ($f eq 'curl'){
3674             $src_switch = ' -L -f -s -S --netrc-optional';
3675           }
3676
3677           if ($f eq "ncftpget"){
3678             $chdir = "cd $aslocal_dir && ";
3679             $stdout_redir = "";
3680           }
3681           $CPAN::Frontend->myprint(
3682                                    qq[
3683 Trying with "$funkyftp$src_switch" to get
3684     $url
3685 ]);
3686           my($system) =
3687               "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
3688           $self->debug("system[$system]") if $CPAN::DEBUG;
3689           my($wstatus) = system($system);
3690           if ($f eq "lynx") {
3691               # lynx returns 0 when it fails somewhere
3692               if (-s $asl_ungz) {
3693                   my $content = do { local *FH;
3694                                      open FH, $asl_ungz or die;
3695                                      local $/;
3696                                      <FH> };
3697                   if ($content =~ /^<.*(<title>[45]|Error [45])/si) {
3698                       $CPAN::Frontend->mywarn(qq{
3699 No success, the file that lynx has has downloaded looks like an error message:
3700 $content
3701 });
3702                       $CPAN::Frontend->mysleep(1);
3703                       next DLPRG;
3704                   }
3705               } else {
3706                   $CPAN::Frontend->myprint(qq{
3707 No success, the file that lynx has has downloaded is an empty file.
3708 });
3709                   next DLPRG;
3710               }
3711           }
3712           if ($wstatus == 0) {
3713             if (-s $aslocal) {
3714               # Looks good
3715             } elsif ($asl_ungz ne $aslocal) {
3716               # test gzip integrity
3717               if (eval{CPAN::Tarzip->new($asl_ungz)->gtest}) {
3718                   # e.g. foo.tar is gzipped --> foo.tar.gz
3719                   rename $asl_ungz, $aslocal;
3720               } else {
3721                   eval{CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz)};
3722               }
3723             }
3724             $ThesiteURL = $ro_url;
3725             return $aslocal;
3726           } elsif ($url !~ /\.gz(?!\n)\Z/) {
3727             unlink $asl_ungz if
3728                 -f $asl_ungz && -s _ == 0;
3729             my $gz = "$aslocal.gz";
3730             my $gzurl = "$url.gz";
3731             $CPAN::Frontend->myprint(
3732                                      qq[
3733 Trying with "$funkyftp$src_switch" to get
3734   $url.gz
3735 ]);
3736             my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
3737             $self->debug("system[$system]") if $CPAN::DEBUG;
3738             my($wstatus);
3739             if (($wstatus = system($system)) == 0
3740                 &&
3741                 -s $asl_gz
3742                ) {
3743               # test gzip integrity
3744                 my $ct = eval{CPAN::Tarzip->new($asl_gz)};
3745                 if ($ct && $ct->gtest) {
3746                     $ct->gunzip($aslocal);
3747                 } else {
3748                     # somebody uncompressed file for us?
3749                     rename $asl_ungz, $aslocal;
3750                 }
3751                 $ThesiteURL = $ro_url;
3752                 return $aslocal;
3753             } else {
3754               unlink $asl_gz if -f $asl_gz;
3755             }
3756           } else {
3757             my $estatus = $wstatus >> 8;
3758             my $size = -f $aslocal ?
3759                 ", left\n$aslocal with size ".-s _ :
3760                     "\nWarning: expected file [$aslocal] doesn't exist";
3761             $CPAN::Frontend->myprint(qq{
3762 System call "$system"
3763 returned status $estatus (wstat $wstatus)$size
3764 });
3765           }
3766           return if $CPAN::Signal;
3767         } # transfer programs
3768     } # host
3769 }
3770
3771 # package CPAN::FTP;
3772 sub hosthardest {
3773     my($self,$host_seq,$file,$aslocal,$stats) = @_;
3774
3775     my($ro_url);
3776     my($aslocal_dir) = File::Basename::dirname($aslocal);
3777     File::Path::mkpath($aslocal_dir);
3778     my $ftpbin = $CPAN::Config->{ftp};
3779     unless ($ftpbin && length $ftpbin && MM->maybe_command($ftpbin)) {
3780         $CPAN::Frontend->myprint("No external ftp command available\n\n");
3781         return;
3782     }
3783     $CPAN::Frontend->mywarn(qq{
3784 As a last ressort we now switch to the external ftp command '$ftpbin'
3785 to get '$aslocal'.
3786
3787 Doing so often leads to problems that are hard to diagnose.
3788
3789 If you're victim of such problems, please consider unsetting the ftp
3790 config variable with
3791
3792     o conf ftp ""
3793     o conf commit
3794
3795 });
3796     $CPAN::Frontend->mysleep(2);
3797   HOSTHARDEST: for $ro_url (@$host_seq) {
3798         $self->_set_attempt($stats,"hardest",$ro_url);
3799         my $url = "$ro_url$file";
3800         $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
3801         unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3802             next;
3803         }
3804         my($host,$dir,$getfile) = ($1,$2,$3);
3805         my $timestamp = 0;
3806         my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
3807            $ctime,$blksize,$blocks) = stat($aslocal);
3808         $timestamp = $mtime ||= 0;
3809         my($netrc) = CPAN::FTP::netrc->new;
3810         my($netrcfile) = $netrc->netrc;
3811         my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
3812         my $targetfile = File::Basename::basename($aslocal);
3813         my(@dialog);
3814         push(
3815              @dialog,
3816              "lcd $aslocal_dir",
3817              "cd /",
3818              map("cd $_", split /\//, $dir), # RFC 1738
3819              "bin",
3820              "get $getfile $targetfile",
3821              "quit"
3822             );
3823         if (! $netrcfile) {
3824             CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
3825         } elsif ($netrc->hasdefault || $netrc->contains($host)) {
3826             CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
3827                                 $netrc->hasdefault,
3828                                 $netrc->contains($host))) if $CPAN::DEBUG;
3829             if ($netrc->protected) {
3830                 my $dialog = join "", map { "    $_\n" } @dialog;
3831                 my $netrc_explain;
3832                 if ($netrc->contains($host)) {
3833                     $netrc_explain = "Relying that your .netrc entry for '$host' ".
3834                         "manages the login";
3835                 } else {
3836                     $netrc_explain = "Relying that your default .netrc entry ".
3837                         "manages the login";
3838                 }
3839                 $CPAN::Frontend->myprint(qq{
3840   Trying with external ftp to get
3841     $url
3842   $netrc_explain
3843   Going to send the dialog
3844 $dialog
3845 }
3846                      );
3847                 $self->talk_ftp("$ftpbin$verbose $host",
3848                                 @dialog);
3849                 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
3850                  $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
3851                 $mtime ||= 0;
3852                 if ($mtime > $timestamp) {
3853                     $CPAN::Frontend->myprint("GOT $aslocal\n");
3854                     $ThesiteURL = $ro_url;
3855                     return $aslocal;
3856                 } else {
3857                     $CPAN::Frontend->myprint("Hmm... Still failed!\n");
3858                 }
3859                 return if $CPAN::Signal;
3860             } else {
3861                 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
3862                                         qq{correctly protected.\n});
3863             }
3864         } else {
3865             $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
3866   nor does it have a default entry\n");
3867         }
3868
3869         # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
3870         # then and login manually to host, using e-mail as
3871         # password.
3872         $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
3873         unshift(
3874                 @dialog,
3875                 "open $host",
3876                 "user anonymous $Config::Config{'cf_email'}"
3877                );
3878         my $dialog = join "", map { "    $_\n" } @dialog;
3879         $CPAN::Frontend->myprint(qq{
3880   Trying with external ftp to get
3881     $url
3882   Going to send the dialog
3883 $dialog
3884 }
3885                      );
3886         $self->talk_ftp("$ftpbin$verbose -n", @dialog);
3887         ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
3888          $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
3889         $mtime ||= 0;
3890         if ($mtime > $timestamp) {
3891             $CPAN::Frontend->myprint("GOT $aslocal\n");
3892             $ThesiteURL = $ro_url;
3893             return $aslocal;
3894         } else {
3895             $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
3896         }
3897         return if $CPAN::Signal;
3898         $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
3899         $CPAN::Frontend->mysleep(2);
3900     } # host
3901 }
3902
3903 # package CPAN::FTP;
3904 sub talk_ftp {
3905     my($self,$command,@dialog) = @_;
3906     my $fh = FileHandle->new;
3907     $fh->open("|$command") or die "Couldn't open ftp: $!";
3908     foreach (@dialog) { $fh->print("$_\n") }
3909     $fh->close;         # Wait for process to complete
3910     my $wstatus = $?;
3911     my $estatus = $wstatus >> 8;
3912     $CPAN::Frontend->myprint(qq{
3913 Subprocess "|$command"
3914   returned status $estatus (wstat $wstatus)
3915 }) if $wstatus;
3916 }
3917
3918 # find2perl needs modularization, too, all the following is stolen
3919 # from there
3920 # CPAN::FTP::ls
3921 sub ls {
3922     my($self,$name) = @_;
3923     my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
3924      $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
3925
3926     my($perms,%user,%group);
3927     my $pname = $name;
3928
3929     if ($blocks) {
3930         $blocks = int(($blocks + 1) / 2);
3931     }
3932     else {
3933         $blocks = int(($sizemm + 1023) / 1024);
3934     }
3935
3936     if    (-f _) { $perms = '-'; }
3937     elsif (-d _) { $perms = 'd'; }
3938     elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
3939     elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
3940     elsif (-p _) { $perms = 'p'; }
3941     elsif (-S _) { $perms = 's'; }
3942     else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
3943
3944     my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
3945     my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
3946     my $tmpmode = $mode;
3947     my $tmp = $rwx[$tmpmode & 7];
3948     $tmpmode >>= 3;
3949     $tmp = $rwx[$tmpmode & 7] . $tmp;
3950     $tmpmode >>= 3;
3951     $tmp = $rwx[$tmpmode & 7] . $tmp;
3952     substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
3953     substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
3954     substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
3955     $perms .= $tmp;
3956
3957     my $user = $user{$uid} || $uid;   # too lazy to implement lookup
3958     my $group = $group{$gid} || $gid;
3959
3960     my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
3961     my($timeyear);
3962     my($moname) = $moname[$mon];
3963     if (-M _ > 365.25 / 2) {
3964         $timeyear = $year + 1900;
3965     }
3966     else {
3967         $timeyear = sprintf("%02d:%02d", $hour, $min);
3968     }
3969
3970     sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
3971             $ino,
3972                  $blocks,
3973                       $perms,
3974                             $nlink,
3975                                 $user,
3976                                      $group,
3977                                           $sizemm,
3978                                               $moname,
3979                                                  $mday,
3980                                                      $timeyear,
3981                                                          $pname;
3982 }
3983
3984 package CPAN::FTP::netrc;
3985 use strict;
3986
3987 # package CPAN::FTP::netrc;
3988 sub new {
3989     my($class) = @_;
3990     my $home = CPAN::HandleConfig::home;
3991     my $file = File::Spec->catfile($home,".netrc");
3992
3993     my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
3994        $atime,$mtime,$ctime,$blksize,$blocks)
3995         = stat($file);
3996     $mode ||= 0;
3997     my $protected = 0;
3998
3999     my($fh,@machines,$hasdefault);
4000     $hasdefault = 0;
4001     $fh = FileHandle->new or die "Could not create a filehandle";
4002
4003     if($fh->open($file)){
4004         $protected = ($mode & 077) == 0;
4005         local($/) = "";
4006       NETRC: while (<$fh>) {
4007             my(@tokens) = split " ", $_;
4008           TOKEN: while (@tokens) {
4009                 my($t) = shift @tokens;
4010                 if ($t eq "default"){
4011                     $hasdefault++;
4012                     last NETRC;
4013                 }
4014                 last TOKEN if $t eq "macdef";
4015                 if ($t eq "machine") {
4016                     push @machines, shift @tokens;
4017                 }
4018             }
4019         }
4020     } else {
4021         $file = $hasdefault = $protected = "";
4022     }
4023
4024     bless {
4025            'mach' => [@machines],
4026            'netrc' => $file,
4027            'hasdefault' => $hasdefault,
4028            'protected' => $protected,
4029           }, $class;
4030 }
4031
4032 # CPAN::FTP::netrc::hasdefault;
4033 sub hasdefault { shift->{'hasdefault'} }
4034 sub netrc      { shift->{'netrc'}      }
4035 sub protected  { shift->{'protected'}  }
4036 sub contains {
4037     my($self,$mach) = @_;
4038     for ( @{$self->{'mach'}} ) {
4039         return 1 if $_ eq $mach;
4040     }
4041     return 0;
4042 }
4043
4044 package CPAN::Complete;
4045 use strict;
4046
4047 sub gnu_cpl {
4048     my($text, $line, $start, $end) = @_;
4049     my(@perlret) = cpl($text, $line, $start);
4050     # find longest common match. Can anybody show me how to peruse
4051     # T::R::Gnu to have this done automatically? Seems expensive.
4052     return () unless @perlret;
4053     my($newtext) = $text;
4054     for (my $i = length($text)+1;;$i++) {
4055         last unless length($perlret[0]) && length($perlret[0]) >= $i;
4056         my $try = substr($perlret[0],0,$i);
4057         my @tries = grep {substr($_,0,$i) eq $try} @perlret;
4058         # warn "try[$try]tries[@tries]";
4059         if (@tries == @perlret) {
4060             $newtext = $try;
4061         } else {
4062             last;
4063         }
4064     }
4065     ($newtext,@perlret);
4066 }
4067
4068 #-> sub CPAN::Complete::cpl ;
4069 sub cpl {
4070     my($word,$line,$pos) = @_;
4071     $word ||= "";
4072     $line ||= "";
4073     $pos ||= 0;
4074     CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4075     $line =~ s/^\s*//;
4076     if ($line =~ s/^(force\s*)//) {
4077         $pos -= length($1);
4078     }
4079     my @return;
4080     if ($pos == 0) {
4081         @return = grep /^$word/, @CPAN::Complete::COMMANDS;
4082     } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
4083         @return = ();
4084     } elsif ($line =~ /^(a|ls)\s/) {
4085         @return = cplx('CPAN::Author',uc($word));
4086     } elsif ($line =~ /^b\s/) {
4087         CPAN::Shell->local_bundles;
4088         @return = cplx('CPAN::Bundle',$word);
4089     } elsif ($line =~ /^d\s/) {
4090         @return = cplx('CPAN::Distribution',$word);
4091     } elsif ($line =~ m/^(
4092                           [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
4093                          )\s/x ) {
4094         if ($word =~ /^Bundle::/) {
4095             CPAN::Shell->local_bundles;
4096         }
4097         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
4098     } elsif ($line =~ /^i\s/) {
4099         @return = cpl_any($word);
4100     } elsif ($line =~ /^reload\s/) {
4101         @return = cpl_reload($word,$line,$pos);
4102     } elsif ($line =~ /^o\s/) {
4103         @return = cpl_option($word,$line,$pos);
4104     } elsif ($line =~ m/^\S+\s/ ) {
4105         # fallback for future commands and what we have forgotten above
4106         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
4107     } else {
4108         @return = ();
4109     }
4110     return @return;
4111 }
4112
4113 #-> sub CPAN::Complete::cplx ;
4114 sub cplx {
4115     my($class, $word) = @_;
4116     # I believed for many years that this was sorted, today I
4117     # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
4118     # make it sorted again. Maybe sort was dropped when GNU-readline
4119     # support came in? The RCS file is difficult to read on that:-(
4120     sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
4121 }
4122
4123 #-> sub CPAN::Complete::cpl_any ;
4124 sub cpl_any {
4125     my($word) = shift;
4126     return (
4127             cplx('CPAN::Author',$word),
4128             cplx('CPAN::Bundle',$word),
4129             cplx('CPAN::Distribution',$word),
4130             cplx('CPAN::Module',$word),
4131            );
4132 }
4133
4134 #-> sub CPAN::Complete::cpl_reload ;
4135 sub cpl_reload {
4136     my($word,$line,$pos) = @_;
4137     $word ||= "";
4138     my(@words) = split " ", $line;
4139     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4140     my(@ok) = qw(cpan index);
4141     return @ok if @words == 1;
4142     return grep /^\Q$word\E/, @ok if @words == 2 && $word;
4143 }
4144
4145 #-> sub CPAN::Complete::cpl_option ;
4146 sub cpl_option {
4147     my($word,$line,$pos) = @_;
4148     $word ||= "";
4149     my(@words) = split " ", $line;
4150     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4151     my(@ok) = qw(conf debug);
4152     return @ok if @words == 1;
4153     return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
4154     if (0) {
4155     } elsif ($words[1] eq 'index') {
4156         return ();
4157     } elsif ($words[1] eq 'conf') {
4158         return CPAN::HandleConfig::cpl(@_);
4159     } elsif ($words[1] eq 'debug') {
4160         return sort grep /^\Q$word\E/i,
4161             sort keys %CPAN::DEBUG, 'all';
4162     }
4163 }
4164
4165 package CPAN::Index;
4166 use strict;
4167
4168 #-> sub CPAN::Index::force_reload ;
4169 sub force_reload {
4170     my($class) = @_;
4171     $CPAN::Index::LAST_TIME = 0;
4172     $class->reload(1);
4173 }
4174
4175 #-> sub CPAN::Index::reload ;
4176 sub reload {
4177     my($self,$force) = @_;
4178     my $time = time;
4179
4180     # XXX check if a newer one is available. (We currently read it
4181     # from time to time)
4182     for ($CPAN::Config->{index_expire}) {
4183         $_ = 0.001 unless $_ && $_ > 0.001;
4184     }
4185     unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
4186         # debug here when CPAN doesn't seem to read the Metadata
4187         require Carp;
4188         Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
4189     }
4190     unless ($CPAN::META->{PROTOCOL}) {
4191         $self->read_metadata_cache;
4192         $CPAN::META->{PROTOCOL} ||= "1.0";
4193     }
4194     if ( $CPAN::META->{PROTOCOL} < PROTOCOL  ) {
4195         # warn "Setting last_time to 0";
4196         $LAST_TIME = 0; # No warning necessary
4197     }
4198     if ($LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
4199         and ! $force){
4200         # called too often
4201         # CPAN->debug("LAST_TIME[$LAST_TIME]index_expire[$CPAN::Config->{index_expire}]time[$time]");
4202     } elsif (0) {
4203         # IFF we are developing, it helps to wipe out the memory
4204         # between reloads, otherwise it is not what a user expects.
4205         undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
4206         $CPAN::META = CPAN->new;
4207     } else {
4208         my($debug,$t2);
4209         local $LAST_TIME = $time;
4210         local $CPAN::META->{PROTOCOL} = PROTOCOL;
4211
4212         my $needshort = $^O eq "dos";
4213
4214         $self->rd_authindex($self
4215                           ->reload_x(
4216                                      "authors/01mailrc.txt.gz",
4217                                      $needshort ?
4218                                      File::Spec->catfile('authors', '01mailrc.gz') :
4219                                      File::Spec->catfile('authors', '01mailrc.txt.gz'),
4220                                      $force));
4221         $t2 = time;
4222         $debug = "timing reading 01[".($t2 - $time)."]";
4223         $time = $t2;
4224         return if $CPAN::Signal; # this is sometimes lengthy
4225         $self->rd_modpacks($self
4226                          ->reload_x(
4227                                     "modules/02packages.details.txt.gz",
4228                                     $needshort ?
4229                                     File::Spec->catfile('modules', '02packag.gz') :
4230                                     File::Spec->catfile('modules', '02packages.details.txt.gz'),
4231                                     $force));
4232         $t2 = time;
4233         $debug .= "02[".($t2 - $time)."]";
4234         $time = $t2;
4235         return if $CPAN::Signal; # this is sometimes lengthy
4236         $self->rd_modlist($self
4237                         ->reload_x(
4238                                    "modules/03modlist.data.gz",
4239                                    $needshort ?
4240                                    File::Spec->catfile('modules', '03mlist.gz') :
4241                                    File::Spec->catfile('modules', '03modlist.data.gz'),
4242                                    $force));
4243         $self->write_metadata_cache;
4244         $t2 = time;
4245         $debug .= "03[".($t2 - $time)."]";
4246         $time = $t2;
4247         CPAN->debug($debug) if $CPAN::DEBUG;
4248     }
4249     if ($CPAN::Config->{build_dir_reuse}) {
4250         $self->reanimate_build_dir;
4251     }
4252     if (CPAN::_sqlite_running) {
4253         $CPAN::SQLite->reload(time => $time, force => $force)
4254             if not $LAST_TIME;
4255     }
4256     $LAST_TIME = $time;
4257     $CPAN::META->{PROTOCOL} = PROTOCOL;
4258 }
4259
4260 #-> sub CPAN::Index::reanimate_build_dir ;
4261 sub reanimate_build_dir {
4262     my($self) = @_;
4263     unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module}||"YAML")) {
4264         return;
4265     }
4266     return if $HAVE_REANIMATED++;
4267     my $d = $CPAN::Config->{build_dir};
4268     my $dh = DirHandle->new;
4269     opendir $dh, $d or return; # does not exist
4270     my $dirent;
4271     my $i = 0;
4272     my $painted = 0;
4273     my $restored = 0;
4274     $CPAN::Frontend->myprint("Going to read $CPAN::Config->{build_dir}/\n");
4275     my @candidates = map { $_->[0] }
4276         sort { $b->[1] <=> $a->[1] }
4277             map { [ $_, -M File::Spec->catfile($d,$_) ] }
4278                 grep {/\.yml$/} readdir $dh;
4279   DISTRO: for $dirent (@candidates) {
4280         my $c = CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))->[0];
4281         if ($c && CPAN->_perl_fingerprint($c->{perl})) {
4282             my $key = $c->{distribution}{ID};
4283             for my $k (keys %{$c->{distribution}}) {
4284                 if ($c->{distribution}{$k}
4285                     && ref $c->{distribution}{$k}
4286                     && UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) {
4287                     $c->{distribution}{$k}{COMMANDID} = $i - @candidates;
4288                 }
4289             }
4290
4291             #we tried to restore only if element already
4292             #exists; but then we do not work with metadata
4293             #turned off.
4294             $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key} = $c->{distribution};
4295             $restored++;
4296         }
4297         $i++;
4298         while (($painted/76) < ($i/@candidates)) {
4299             $CPAN::Frontend->myprint(".");
4300             $painted++;
4301         }
4302     }
4303     $CPAN::Frontend->myprint(sprintf(
4304                                      "DONE\nFound %s old builds, restored the state of %s\n",
4305                                      @candidates ? sprintf("%d",scalar @candidates) : "no",
4306                                      $restored || "none",
4307                                     ));
4308 }
4309
4310
4311 #-> sub CPAN::Index::reload_x ;
4312 sub reload_x {
4313     my($cl,$wanted,$localname,$force) = @_;
4314     $force |= 2; # means we're dealing with an index here
4315     CPAN::HandleConfig->load; # we should guarantee loading wherever
4316                               # we rely on Config XXX
4317     $localname ||= $wanted;
4318     my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
4319                                          $localname);
4320     if (
4321         -f $abs_wanted &&
4322         -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
4323         !($force & 1)
4324        ) {
4325         my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
4326         $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
4327                    qq{day$s. I\'ll use that.});
4328         return $abs_wanted;
4329     } else {
4330         $force |= 1; # means we're quite serious about it.
4331     }
4332     return CPAN::FTP->localize($wanted,$abs_wanted,$force);
4333 }
4334
4335 #-> sub CPAN::Index::rd_authindex ;
4336 sub rd_authindex {
4337     my($cl, $index_target) = @_;
4338     return unless defined $index_target;
4339     return if CPAN::_sqlite_running;
4340     my @lines;
4341     $CPAN::Frontend->myprint("Going to read $index_target\n");
4342     local(*FH);
4343     tie *FH, 'CPAN::Tarzip', $index_target;
4344     local($/) = "\n";
4345     local($_);
4346     push @lines, split /\012/ while <FH>;
4347     my $i = 0;
4348     my $painted = 0;
4349     foreach (@lines) {
4350         my($userid,$fullname,$email) =
4351             m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/;
4352         $fullname ||= $email;
4353         if ($userid && $fullname && $email){
4354             my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
4355             $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
4356         } else {
4357             CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG;
4358         }
4359         $i++;
4360         while (($painted/76) < ($i/@lines)) {
4361             $CPAN::Frontend->myprint(".");
4362             $painted++;
4363         }
4364         return if $CPAN::Signal;
4365     }
4366     $CPAN::Frontend->myprint("DONE\n");
4367 }
4368
4369 sub userid {
4370   my($self,$dist) = @_;
4371   $dist = $self->{'id'} unless defined $dist;
4372   my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
4373   $ret;
4374 }
4375
4376 #-> sub CPAN::Index::rd_modpacks ;
4377 sub rd_modpacks {
4378     my($self, $index_target) = @_;
4379     return unless defined $index_target;
4380     return if CPAN::_sqlite_running;
4381     $CPAN::Frontend->myprint("Going to read $index_target\n");
4382     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
4383     local $_;
4384     CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
4385     my $slurp = "";
4386     my $chunk;
4387     while (my $bytes = $fh->READ(\$chunk,8192)) {
4388         $slurp.=$chunk;
4389     }
4390     my @lines = split /\012/, $slurp;
4391     CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
4392     undef $fh;
4393     # read header
4394     my($line_count,$last_updated);
4395     while (@lines) {
4396         my $shift = shift(@lines);
4397         last if $shift =~ /^\s*$/;
4398         $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
4399         $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
4400     }
4401     CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
4402     if (not defined $line_count) {
4403
4404         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
4405 Please check the validity of the index file by comparing it to more
4406 than one CPAN mirror. I'll continue but problems seem likely to
4407 happen.\a
4408 });
4409
4410         $CPAN::Frontend->mysleep(5);
4411     } elsif ($line_count != scalar @lines) {
4412
4413         $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
4414 contains a Line-Count header of %d but I see %d lines there. Please
4415 check the validity of the index file by comparing it to more than one
4416 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
4417 $index_target, $line_count, scalar(@lines));
4418
4419     }
4420     if (not defined $last_updated) {
4421
4422         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
4423 Please check the validity of the index file by comparing it to more
4424 than one CPAN mirror. I'll continue but problems seem likely to
4425 happen.\a
4426 });
4427
4428         $CPAN::Frontend->mysleep(5);
4429     } else {
4430
4431         $CPAN::Frontend
4432             ->myprint(sprintf qq{  Database was generated on %s\n},
4433                       $last_updated);
4434         $DATE_OF_02 = $last_updated;
4435
4436         my $age = time;
4437         if ($CPAN::META->has_inst('HTTP::Date')) {
4438             require HTTP::Date;
4439             $age -= HTTP::Date::str2time($last_updated);
4440         } else {
4441             $CPAN::Frontend->mywarn("  HTTP::Date not available\n");
4442             require Time::Local;
4443             my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
4444             $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
4445             $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
4446         }
4447         $age /= 3600*24;
4448         if ($age > 30) {
4449
4450             $CPAN::Frontend
4451                 ->mywarn(sprintf
4452                          qq{Warning: This index file is %d days old.
4453   Please check the host you chose as your CPAN mirror for staleness.
4454   I'll continue but problems seem likely to happen.\a\n},
4455                          $age);
4456
4457         } elsif ($age < -1) {
4458
4459             $CPAN::Frontend
4460                 ->mywarn(sprintf
4461                          qq{Warning: Your system date is %d days behind this index file!
4462   System time:          %s
4463   Timestamp index file: %s
4464   Please fix your system time, problems with the make command expected.\n},
4465                          -$age,
4466                          scalar gmtime,
4467                          $DATE_OF_02,
4468                         );
4469
4470         }
4471     }
4472
4473
4474     # A necessity since we have metadata_cache: delete what isn't
4475     # there anymore
4476     my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
4477     CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
4478     my(%exists);
4479     my $i = 0;
4480     my $painted = 0;
4481     foreach (@lines) {
4482         # before 1.56 we split into 3 and discarded the rest. From
4483         # 1.57 we assign remaining text to $comment thus allowing to
4484         # influence isa_perl
4485         my($mod,$version,$dist,$comment) = split " ", $_, 4;
4486         my($bundle,$id,$userid);
4487
4488         if ($mod eq 'CPAN' &&
4489             ! (
4490                CPAN::Queue->exists('Bundle::CPAN') ||
4491                CPAN::Queue->exists('CPAN')
4492               )
4493            ) {
4494             local($^W)= 0;
4495             if ($version > $CPAN::VERSION){
4496                 $CPAN::Frontend->mywarn(qq{
4497   New CPAN.pm version (v$version) available.
4498   [Currently running version is v$CPAN::VERSION]
4499   You might want to try
4500     install CPAN
4501     reload cpan
4502   to both upgrade CPAN.pm and run the new version without leaving
4503   the current session.
4504
4505 }); #});
4506                 $CPAN::Frontend->mysleep(2);
4507                 $CPAN::Frontend->myprint(qq{\n});
4508             }
4509             last if $CPAN::Signal;
4510         } elsif ($mod =~ /^Bundle::(.*)/) {
4511             $bundle = $1;
4512         }
4513
4514         if ($bundle){
4515             $id =  $CPAN::META->instance('CPAN::Bundle',$mod);
4516             # Let's make it a module too, because bundles have so much
4517             # in common with modules.
4518
4519             # Changed in 1.57_63: seems like memory bloat now without
4520             # any value, so commented out
4521
4522             # $CPAN::META->instance('CPAN::Module',$mod);
4523
4524         } else {
4525
4526             # instantiate a module object
4527             $id = $CPAN::META->instance('CPAN::Module',$mod);
4528
4529         }
4530
4531         # Although CPAN prohibits same name with different version the
4532         # indexer may have changed the version for the same distro
4533         # since the last time ("Force Reindexing" feature)
4534         if ($id->cpan_file ne $dist
4535             ||
4536             $id->cpan_version ne $version
4537            ){
4538             $userid = $id->userid || $self->userid($dist);
4539             $id->set(
4540                      'CPAN_USERID' => $userid,
4541                      'CPAN_VERSION' => $version,
4542                      'CPAN_FILE' => $dist,
4543                     );
4544         }
4545
4546         # instantiate a distribution object
4547         if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
4548           # we do not need CONTAINSMODS unless we do something with
4549           # this dist, so we better produce it on demand.
4550
4551           ## my $obj = $CPAN::META->instance(
4552           ##                              'CPAN::Distribution' => $dist
4553           ##                             );
4554           ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
4555         } else {
4556           $CPAN::META->instance(
4557                                 'CPAN::Distribution' => $dist
4558                                )->set(
4559                                       'CPAN_USERID' => $userid,
4560                                       'CPAN_COMMENT' => $comment,
4561                                      );
4562         }
4563         if ($secondtime) {
4564             for my $name ($mod,$dist) {
4565                 # $self->debug("exists name[$name]") if $CPAN::DEBUG;
4566                 $exists{$name} = undef;
4567             }
4568         }
4569         $i++;
4570         while (($painted/76) < ($i/@lines)) {
4571             $CPAN::Frontend->myprint(".");
4572             $painted++;
4573         }
4574         return if $CPAN::Signal;
4575     }
4576     $CPAN::Frontend->myprint("DONE\n");
4577     if ($secondtime) {
4578         for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
4579             for my $o ($CPAN::META->all_objects($class)) {
4580                 next if exists $exists{$o->{ID}};
4581                 $CPAN::META->delete($class,$o->{ID});
4582                 # CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
4583                 #     if $CPAN::DEBUG;
4584             }
4585         }
4586     }
4587 }
4588
4589 #-> sub CPAN::Index::rd_modlist ;
4590 sub rd_modlist {
4591     my($cl,$index_target) = @_;
4592     return unless defined $index_target;
4593     return if CPAN::_sqlite_running;
4594     $CPAN::Frontend->myprint("Going to read $index_target\n");
4595     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
4596     local $_;
4597     my $slurp = "";
4598     my $chunk;
4599     while (my $bytes = $fh->READ(\$chunk,8192)) {
4600         $slurp.=$chunk;
4601     }
4602     my @eval2 = split /\012/, $slurp;
4603
4604     while (@eval2) {
4605         my $shift = shift(@eval2);
4606         if ($shift =~ /^Date:\s+(.*)/){
4607             if ($DATE_OF_03 eq $1){
4608                 $CPAN::Frontend->myprint("Unchanged.\n");
4609                 return;
4610             }
4611             ($DATE_OF_03) = $1;
4612         }
4613         last if $shift =~ /^\s*$/;
4614     }
4615     push @eval2, q{CPAN::Modulelist->data;};
4616     local($^W) = 0;
4617     my($comp) = Safe->new("CPAN::Safe1");
4618     my($eval2) = join("\n", @eval2);
4619     CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG;
4620     my $ret = $comp->reval($eval2);
4621     Carp::confess($@) if $@;
4622     return if $CPAN::Signal;
4623     my $i = 0;
4624     my $until = keys(%$ret);
4625     my $painted = 0;
4626     CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
4627     for (keys %$ret) {
4628         my $obj = $CPAN::META->instance("CPAN::Module",$_);
4629         delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
4630         $obj->set(%{$ret->{$_}});
4631         $i++;
4632         while (($painted/76) < ($i/$until)) {
4633             $CPAN::Frontend->myprint(".");
4634             $painted++;
4635         }
4636         return if $CPAN::Signal;
4637     }
4638     $CPAN::Frontend->myprint("DONE\n");
4639 }
4640
4641 #-> sub CPAN::Index::write_metadata_cache ;
4642 sub write_metadata_cache {
4643     my($self) = @_;
4644     return unless $CPAN::Config->{'cache_metadata'};
4645     return if CPAN::_sqlite_running;
4646     return unless $CPAN::META->has_usable("Storable");
4647     my $cache;
4648     foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
4649                       CPAN::Distribution)) {
4650         $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
4651     }
4652     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
4653     $cache->{last_time} = $LAST_TIME;
4654     $cache->{DATE_OF_02} = $DATE_OF_02;
4655     $cache->{PROTOCOL} = PROTOCOL;
4656     $CPAN::Frontend->myprint("Going to write $metadata_file\n");
4657     eval { Storable::nstore($cache, $metadata_file) };
4658     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
4659 }
4660
4661 #-> sub CPAN::Index::read_metadata_cache ;
4662 sub read_metadata_cache {
4663     my($self) = @_;
4664     return unless $CPAN::Config->{'cache_metadata'};
4665     return if CPAN::_sqlite_running;
4666     return unless $CPAN::META->has_usable("Storable");
4667     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
4668     return unless -r $metadata_file and -f $metadata_file;
4669     $CPAN::Frontend->myprint("Going to read $metadata_file\n");
4670     my $cache;
4671     eval { $cache = Storable::retrieve($metadata_file) };
4672     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
4673     if (!$cache || !UNIVERSAL::isa($cache, 'HASH')){
4674         $LAST_TIME = 0;
4675         return;
4676     }
4677     if (exists $cache->{PROTOCOL}) {
4678         if (PROTOCOL > $cache->{PROTOCOL}) {
4679             $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
4680                                             "with protocol v%s, requiring v%s\n",
4681                                             $cache->{PROTOCOL},
4682                                             PROTOCOL)
4683                                    );
4684             return;
4685         }
4686     } else {
4687         $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
4688                                 "with protocol v1.0\n");
4689         return;
4690     }
4691     my $clcnt = 0;
4692     my $idcnt = 0;
4693     while(my($class,$v) = each %$cache) {
4694         next unless $class =~ /^CPAN::/;
4695         $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
4696         while (my($id,$ro) = each %$v) {
4697             $CPAN::META->{readwrite}{$class}{$id} ||=
4698                 $class->new(ID=>$id, RO=>$ro);
4699             $idcnt++;
4700         }
4701         $clcnt++;
4702     }
4703     unless ($clcnt) { # sanity check
4704         $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
4705         return;
4706     }
4707     if ($idcnt < 1000) {
4708         $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
4709                                  "in $metadata_file\n");
4710         return;
4711     }
4712     $CPAN::META->{PROTOCOL} ||=
4713         $cache->{PROTOCOL}; # reading does not up or downgrade, but it
4714                             # does initialize to some protocol
4715     $LAST_TIME = $cache->{last_time};
4716     $DATE_OF_02 = $cache->{DATE_OF_02};
4717     $CPAN::Frontend->myprint("  Database was generated on $DATE_OF_02\n")
4718         if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
4719     return;
4720 }
4721
4722 package CPAN::InfoObj;
4723 use strict;
4724
4725 sub ro {
4726     my $self = shift;
4727     exists $self->{RO} and return $self->{RO};
4728 }
4729
4730 #-> sub CPAN::InfoObj::cpan_userid
4731 sub cpan_userid {
4732     my $self = shift;
4733     my $ro = $self->ro;
4734     if ($ro) {
4735         return $ro->{CPAN_USERID} || "N/A";
4736     } else {
4737         $self->debug("ID[$self->{ID}]");
4738         # N/A for bundles found locally
4739         return "N/A";
4740     }
4741 }
4742
4743 sub id { shift->{ID}; }
4744
4745 #-> sub CPAN::InfoObj::new ;
4746 sub new {
4747     my $this = bless {}, shift;
4748     %$this = @_;
4749     $this
4750 }
4751
4752 # The set method may only be used by code that reads index data or
4753 # otherwise "objective" data from the outside world. All session
4754 # related material may do anything else with instance variables but
4755 # must not touch the hash under the RO attribute. The reason is that
4756 # the RO hash gets written to Metadata file and is thus persistent.
4757
4758 #-> sub CPAN::InfoObj::safe_chdir ;
4759 sub safe_chdir {
4760   my($self,$todir) = @_;
4761   # we die if we cannot chdir and we are debuggable
4762   Carp::confess("safe_chdir called without todir argument")
4763         unless defined $todir and length $todir;
4764   if (chdir $todir) {
4765     $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
4766         if $CPAN::DEBUG;
4767   } else {
4768     if (-e $todir) {
4769         unless (-x $todir) {
4770             unless (chmod 0755, $todir) {
4771                 my $cwd = CPAN::anycwd();
4772                 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
4773                                         "permission to change the permission; cannot ".
4774                                         "chdir to '$todir'\n");
4775                 $CPAN::Frontend->mysleep(5);
4776                 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
4777                                        qq{to todir[$todir]: $!});
4778             }
4779         }
4780     } else {
4781         $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n");
4782     }
4783     if (chdir $todir) {
4784       $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
4785           if $CPAN::DEBUG;
4786     } else {
4787       my $cwd = CPAN::anycwd();
4788       $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
4789                              qq{to todir[$todir] (a chmod has been issued): $!});
4790     }
4791   }
4792 }
4793
4794 #-> sub CPAN::InfoObj::set ;
4795 sub set {
4796     my($self,%att) = @_;
4797     my $class = ref $self;
4798
4799     # This must be ||=, not ||, because only if we write an empty
4800     # reference, only then the set method will write into the readonly
4801     # area. But for Distributions that spring into existence, maybe
4802     # because of a typo, we do not like it that they are written into
4803     # the readonly area and made permanent (at least for a while) and
4804     # that is why we do not "allow" other places to call ->set.
4805     unless ($self->id) {
4806         CPAN->debug("Bug? Empty ID, rejecting");
4807         return;
4808     }
4809     my $ro = $self->{RO} =
4810         $CPAN::META->{readonly}{$class}{$self->id} ||= {};
4811
4812     while (my($k,$v) = each %att) {
4813         $ro->{$k} = $v;
4814     }
4815 }
4816
4817 #-> sub CPAN::InfoObj::as_glimpse ;
4818 sub as_glimpse {
4819     my($self) = @_;
4820     my(@m);
4821     my $class = ref($self);
4822     $class =~ s/^CPAN:://;
4823     my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID};
4824     push @m, sprintf "%-15s %s\n", $class, $id;
4825     join "", @m;
4826 }
4827
4828 #-> sub CPAN::InfoObj::as_string ;
4829 sub as_string {
4830     my($self) = @_;
4831     my(@m);
4832     my $class = ref($self);
4833     $class =~ s/^CPAN:://;
4834     push @m, $class, " id = $self->{ID}\n";
4835     my $ro;
4836     unless ($ro = $self->ro) {
4837         if (substr($self->{ID},-1,1) eq ".") { # directory
4838             $ro = +{};
4839         } else {
4840             $CPAN::Frontend->mydie("Unknown object $self->{ID}");
4841         }
4842     }
4843     for (sort keys %$ro) {
4844         # next if m/^(ID|RO)$/;
4845         my $extra = "";
4846         if ($_ eq "CPAN_USERID") {
4847             $extra .= " (";
4848             $extra .= $self->fullname;
4849             my $email; # old perls!
4850             if ($email = $CPAN::META->instance("CPAN::Author",
4851                                                $self->cpan_userid
4852                                               )->email) {
4853                 $extra .= " <$email>";
4854             } else {
4855                 $extra .= " <no email>";
4856             }
4857             $extra .= ")";
4858         } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
4859             push @m, sprintf "    %-12s %s\n", $_, $self->fullname;
4860             next;
4861         }
4862         next unless defined $ro->{$_};
4863         push @m, sprintf "    %-12s %s%s\n", $_, $ro->{$_}, $extra;
4864     }
4865   KEY: for (sort keys %$self) {
4866         next if m/^(ID|RO)$/;
4867         unless (defined $self->{$_}) {
4868             delete $self->{$_};
4869             next KEY;
4870         }
4871         if (ref($self->{$_}) eq "ARRAY") {
4872           push @m, sprintf "    %-12s %s\n", $_, "@{$self->{$_}}";
4873         } elsif (ref($self->{$_}) eq "HASH") {
4874             my $value;
4875             if (/^CONTAINSMODS$/) {
4876                 $value = join(" ",sort keys %{$self->{$_}});
4877             } elsif (/^prereq_pm$/) {
4878                 my @value;
4879                 my $v = $self->{$_};
4880                 for my $x (sort keys %$v) {
4881                     my @svalue;
4882                     for my $y (sort keys %{$v->{$x}}) {
4883                         push @svalue, "$y=>$v->{$x}{$y}";
4884                     }
4885                     push @value, "$x\:" . join ",", @svalue if @svalue;
4886                 }
4887                 $value = join ";", @value;
4888             } else {
4889                 $value = $self->{$_};
4890             }
4891           push @m, sprintf(
4892                            "    %-12s %s\n",
4893                            $_,
4894                            $value,
4895                           );
4896         } else {
4897           push @m, sprintf "    %-12s %s\n", $_, $self->{$_};
4898         }
4899     }
4900     join "", @m, "\n";
4901 }
4902
4903 #-> sub CPAN::InfoObj::fullname ;
4904 sub fullname {
4905     my($self) = @_;
4906     $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
4907 }
4908
4909 #-> sub CPAN::InfoObj::dump ;
4910 sub dump {
4911   my($self, $what) = @_;
4912   unless ($CPAN::META->has_inst("Data::Dumper")) {
4913       $CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
4914   }
4915   local $Data::Dumper::Sortkeys;
4916   $Data::Dumper::Sortkeys = 1;
4917   my $out = Data::Dumper::Dumper($what ? eval $what : $self);
4918   if (length $out > 100000) {
4919       my $fh_pager = FileHandle->new;
4920       local($SIG{PIPE}) = "IGNORE";
4921       my $pager = $CPAN::Config->{'pager'} || "cat";
4922       $fh_pager->open("|$pager")
4923           or die "Could not open pager $pager\: $!";
4924       $fh_pager->print($out);
4925       close $fh_pager;
4926   } else {
4927       $CPAN::Frontend->myprint($out);
4928   }
4929 }
4930
4931 package CPAN::Author;
4932 use strict;
4933
4934 #-> sub CPAN::Author::force
4935 sub force {
4936     my $self = shift;
4937     $self->{force}++;
4938 }
4939
4940 #-> sub CPAN::Author::force
4941 sub unforce {
4942     my $self = shift;
4943     delete $self->{force};
4944 }
4945
4946 #-> sub CPAN::Author::id
4947 sub id {
4948     my $self = shift;
4949     my $id = $self->{ID};
4950     $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
4951     $id;
4952 }
4953
4954 #-> sub CPAN::Author::as_glimpse ;
4955 sub as_glimpse {
4956     my($self) = @_;
4957     my(@m);
4958     my $class = ref($self);
4959     $class =~ s/^CPAN:://;
4960     push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
4961                      $class,
4962                      $self->{ID},
4963                      $self->fullname,
4964                      $self->email);
4965     join "", @m;
4966 }
4967
4968 #-> sub CPAN::Author::fullname ;
4969 sub fullname {
4970     shift->ro->{FULLNAME};
4971 }
4972 *name = \&fullname;
4973
4974 #-> sub CPAN::Author::email ;
4975 sub email    { shift->ro->{EMAIL}; }
4976
4977 #-> sub CPAN::Author::ls ;
4978 sub ls {
4979     my $self = shift;
4980     my $glob = shift || "";
4981     my $silent = shift || 0;
4982     my $id = $self->id;
4983
4984     # adapted from CPAN::Distribution::verifyCHECKSUM ;
4985     my(@csf); # chksumfile
4986     @csf = $self->id =~ /(.)(.)(.*)/;
4987     $csf[1] = join "", @csf[0,1];
4988     $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
4989     my(@dl);
4990     @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
4991     unless (grep {$_->[2] eq $csf[1]} @dl) {
4992         $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
4993         return;
4994     }
4995     @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
4996     unless (grep {$_->[2] eq $csf[2]} @dl) {
4997         $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
4998         return;
4999     }
5000     @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
5001     if ($glob) {
5002         if ($CPAN::META->has_inst("Text::Glob")) {
5003             my $rglob = Text::Glob::glob_to_regex($glob);
5004             @dl = grep { $_->[2] =~ /$rglob/ } @dl;
5005         } else {
5006             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
5007         }
5008     }
5009     $CPAN::Frontend->myprint(join "", map {
5010         sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
5011     } sort { $a->[2] cmp $b->[2] } @dl);
5012     @dl;
5013 }
5014
5015 # returns an array of arrays, the latter contain (size,mtime,filename)
5016 #-> sub CPAN::Author::dir_listing ;
5017 sub dir_listing {
5018     my $self = shift;
5019     my $chksumfile = shift;
5020     my $recursive = shift;
5021     my $may_ftp = shift;
5022
5023     my $lc_want =
5024         File::Spec->catfile($CPAN::Config->{keep_source_where},
5025                             "authors", "id", @$chksumfile);
5026
5027     my $fh;
5028
5029     # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
5030     # hazard.  (Without GPG installed they are not that much better,
5031     # though.)
5032     $fh = FileHandle->new;
5033     if (open($fh, $lc_want)) {
5034         my $line = <$fh>; close $fh;
5035         unlink($lc_want) unless $line =~ /PGP/;
5036     }
5037
5038     local($") = "/";
5039     # connect "force" argument with "index_expire".
5040     my $force = $self->{force};
5041     if (my @stat = stat $lc_want) {
5042         $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
5043     }
5044     my $lc_file;
5045     if ($may_ftp) {
5046         $lc_file = CPAN::FTP->localize(
5047                                        "authors/id/@$chksumfile",
5048                                        $lc_want,
5049                                        $force,
5050                                       );
5051         unless ($lc_file) {
5052             $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
5053             $chksumfile->[-1] .= ".gz";
5054             $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
5055                                            "$lc_want.gz",1);
5056             if ($lc_file) {
5057                 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
5058                 eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
5059             } else {
5060                 return;
5061             }
5062         }
5063     } else {
5064         $lc_file = $lc_want;
5065         # we *could* second-guess and if the user has a file: URL,
5066         # then we could look there. But on the other hand, if they do
5067         # have a file: URL, wy did they choose to set
5068         # $CPAN::Config->{show_upload_date} to false?
5069     }
5070
5071     # adapted from CPAN::Distribution::CHECKSUM_check_file ;
5072     $fh = FileHandle->new;
5073     my($cksum);
5074     if (open $fh, $lc_file){
5075         local($/);
5076         my $eval = <$fh>;
5077         $eval =~ s/\015?\012/\n/g;
5078         close $fh;
5079         my($comp) = Safe->new();
5080         $cksum = $comp->reval($eval);
5081         if ($@) {
5082             rename $lc_file, "$lc_file.bad";
5083             Carp::confess($@) if $@;
5084         }
5085     } elsif ($may_ftp) {
5086         Carp::carp "Could not open '$lc_file' for reading.";
5087     } else {
5088         # Maybe should warn: "You may want to set show_upload_date to a true value"
5089         return;
5090     }
5091     my(@result,$f);
5092     for $f (sort keys %$cksum) {
5093         if (exists $cksum->{$f}{isdir}) {
5094             if ($recursive) {
5095                 my(@dir) = @$chksumfile;
5096                 pop @dir;
5097                 push @dir, $f, "CHECKSUMS";
5098                 push @result, map {
5099                     [$_->[0], $_->[1], "$f/$_->[2]"]
5100                 } $self->dir_listing(\@dir,1,$may_ftp);
5101             } else {
5102                 push @result, [ 0, "-", $f ];
5103             }
5104         } else {
5105             push @result, [
5106                            ($cksum->{$f}{"size"}||0),
5107                            $cksum->{$f}{"mtime"}||"---",
5108                            $f
5109                           ];
5110         }
5111     }
5112     @result;
5113 }
5114
5115 package CPAN::Distribution;
5116 use strict;
5117
5118 # Accessors
5119 sub cpan_comment {
5120     my $self = shift;
5121     my $ro = $self->ro or return;
5122     $ro->{CPAN_COMMENT}
5123 }
5124
5125 # CPAN::Distribution::undelay
5126 sub undelay {
5127     my $self = shift;
5128     delete $self->{later};
5129 }
5130
5131 # add the A/AN/ stuff
5132 # CPAN::Distribution::normalize
5133 sub normalize {
5134     my($self,$s) = @_;
5135     $s = $self->id unless defined $s;
5136     if (substr($s,-1,1) eq ".") {
5137         # using a global because we are sometimes called as static method
5138         if (!$CPAN::META->{LOCK}
5139             && !$CPAN::Have_warned->{"$s is unlocked"}++
5140            ) {
5141             $CPAN::Frontend->mywarn("You are visiting the local directory
5142   '$s'
5143   without lock, take care that concurrent processes do not do likewise.\n");
5144             $CPAN::Frontend->mysleep(1);
5145         }
5146         if ($s eq ".") {
5147             $s = "$CPAN::iCwd/.";
5148         } elsif (File::Spec->file_name_is_absolute($s)) {
5149         } elsif (File::Spec->can("rel2abs")) {
5150             $s = File::Spec->rel2abs($s);
5151         } else {
5152             $CPAN::Frontend->mydie("Your File::Spec is too old, please upgrade File::Spec");
5153         }
5154         CPAN->debug("s[$s]") if $CPAN::DEBUG;
5155         unless ($CPAN::META->exists("CPAN::Distribution", $s)) {
5156             for ($CPAN::META->instance("CPAN::Distribution", $s)) {
5157                 $_->{build_dir} = $s;
5158                 $_->{archived} = "local_directory";
5159                 $_->{unwrapped} = CPAN::Distrostatus->new("YES -- local_directory");
5160             }
5161         }
5162     } elsif (
5163         $s =~ tr|/|| == 1
5164         or
5165         $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
5166        ) {
5167         return $s if $s =~ m:^N/A|^Contact Author: ;
5168         $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
5169             $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
5170         CPAN->debug("s[$s]") if $CPAN::DEBUG;
5171     }
5172     $s;
5173 }
5174
5175 #-> sub CPAN::Distribution::author ;
5176 sub author {
5177     my($self) = @_;
5178     my($authorid);
5179     if (substr($self->id,-1,1) eq ".") {
5180         $authorid = "LOCAL";
5181     } else {
5182         ($authorid) = $self->pretty_id =~ /^([\w\-]+)/;
5183     }
5184     CPAN::Shell->expand("Author",$authorid);
5185 }
5186
5187 # tries to get the yaml from CPAN instead of the distro itself:
5188 # EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels
5189 sub fast_yaml {
5190     my($self) = @_;
5191     my $meta = $self->pretty_id;
5192     $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/;
5193     my(@ls) = CPAN::Shell->globls($meta);
5194     my $norm = $self->normalize($meta);
5195
5196     my($local_file);
5197     my($local_wanted) =
5198         File::Spec->catfile(
5199                             $CPAN::Config->{keep_source_where},
5200                             "authors",
5201                             "id",
5202                             split(/\//,$norm)
5203                            );
5204     $self->debug("Doing localize") if $CPAN::DEBUG;
5205     unless ($local_file =
5206             CPAN::FTP->localize("authors/id/$norm",
5207                                 $local_wanted)) {
5208         $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n");
5209     }
5210     my $yaml = CPAN->_yaml_loadfile($local_file)->[0];
5211 }
5212
5213 #-> sub CPAN::Distribution::cpan_userid
5214 sub cpan_userid {
5215     my $self = shift;
5216     if ($self->{ID} =~ m{[A-Z]/[A-Z\-]{2}/([A-Z\-]+)/}) {
5217         return $1;
5218     }
5219     return $self->SUPER::cpan_userid;
5220 }
5221
5222 #-> sub CPAN::Distribution::pretty_id
5223 sub pretty_id {
5224     my $self = shift;
5225     my $id = $self->id;
5226     return $id unless $id =~ m|^./../|;
5227     substr($id,5);
5228 }
5229
5230 # mark as dirty/clean
5231 #-> sub CPAN::Distribution::color_cmd_tmps ;
5232 sub color_cmd_tmps {
5233     my($self) = shift;
5234     my($depth) = shift || 0;
5235     my($color) = shift || 0;
5236     my($ancestors) = shift || [];
5237     # a distribution needs to recurse into its prereq_pms
5238
5239     return if exists $self->{incommandcolor}
5240         && $self->{incommandcolor}==$color;
5241     if ($depth>=100){
5242         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
5243     }
5244     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5245     my $prereq_pm = $self->prereq_pm;
5246     if (defined $prereq_pm) {
5247       PREREQ: for my $pre (keys %{$prereq_pm->{requires}||{}},
5248                            keys %{$prereq_pm->{build_requires}||{}}) {
5249             next PREREQ if $pre eq "perl";
5250             my $premo;
5251             unless ($premo = CPAN::Shell->expand("Module",$pre)) {
5252                 $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n");
5253                 $CPAN::Frontend->mysleep(2);
5254                 next PREREQ;
5255             }
5256             $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5257         }
5258     }
5259     if ($color==0) {
5260         delete $self->{sponsored_mods};
5261         delete $self->{badtestcnt};
5262     }
5263     $self->{incommandcolor} = $color;
5264 }
5265
5266 #-> sub CPAN::Distribution::as_string ;
5267 sub as_string {
5268   my $self = shift;
5269   $self->containsmods;
5270   $self->upload_date;
5271   $self->SUPER::as_string(@_);
5272 }
5273
5274 #-> sub CPAN::Distribution::containsmods ;
5275 sub containsmods {
5276   my $self = shift;
5277   return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
5278   my $dist_id = $self->{ID};
5279   for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
5280     my $mod_file = $mod->cpan_file or next;
5281     my $mod_id = $mod->{ID} or next;
5282     # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
5283     # sleep 1;
5284     $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
5285   }
5286   keys %{$self->{CONTAINSMODS}};
5287 }
5288
5289 #-> sub CPAN::Distribution::upload_date ;
5290 sub upload_date {
5291   my $self = shift;
5292   return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
5293   my(@local_wanted) = split(/\//,$self->id);
5294   my $filename = pop @local_wanted;
5295   push @local_wanted, "CHECKSUMS";
5296   my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
5297   return unless $author;
5298   my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
5299   return unless @dl;
5300   my($dirent) = grep { $_->[2] eq $filename } @dl;
5301   # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
5302   return unless $dirent->[1];
5303   return $self->{UPLOAD_DATE} = $dirent->[1];
5304 }
5305
5306 #-> sub CPAN::Distribution::uptodate ;
5307 sub uptodate {
5308     my($self) = @_;
5309     my $c;
5310     foreach $c ($self->containsmods) {
5311         my $obj = CPAN::Shell->expandany($c);
5312         unless ($obj->uptodate){
5313             my $id = $self->pretty_id;
5314             $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG;
5315             return 0;
5316         }
5317     }
5318     return 1;
5319 }
5320
5321 #-> sub CPAN::Distribution::called_for ;
5322 sub called_for {
5323     my($self,$id) = @_;
5324     $self->{CALLED_FOR} = $id if defined $id;
5325     return $self->{CALLED_FOR};
5326 }
5327
5328 #-> sub CPAN::Distribution::get ;
5329 sub get {
5330     my($self) = @_;
5331     if (my $goto = $self->prefs->{goto}) {
5332         $CPAN::Frontend->mywarn
5333             (sprintf(
5334                      "delegating to '%s' as specified in prefs file '%s' doc %d\n",
5335                      $goto,
5336                      $self->{prefs_file},
5337                      $self->{prefs_file_doc},
5338                     ));
5339         return $self->goto($goto);
5340     }
5341     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
5342                            ? $ENV{PERL5LIB}
5343                            : ($ENV{PERLLIB} || "");
5344
5345     $CPAN::META->set_perl5lib;
5346     local $ENV{MAKEFLAGS}; # protect us from outer make calls
5347
5348   EXCUSE: {
5349         my @e;
5350         if ($self->prefs->{disabled}) {
5351             my $why = sprintf(
5352                               "Disabled via prefs file '%s' doc %d",
5353                               $self->{prefs_file},
5354                               $self->{prefs_file_doc},
5355                              );
5356             push @e, $why;
5357             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $why");
5358             # note: not intended to be persistent but at least visible
5359             # during this session
5360         } else {
5361             exists $self->{build_dir} and push @e,
5362                 "Is already unwrapped into directory $self->{build_dir}";
5363
5364             exists $self->{unwrapped} and (
5365                                            UNIVERSAL::can($self->{unwrapped},"failed") ?
5366                                            $self->{unwrapped}->failed :
5367                                            $self->{unwrapped} =~ /^NO/
5368                                           )
5369                 and push @e, "Unwrapping had some problem, won't try again without force";
5370         }
5371
5372         $CPAN::Frontend->mywarn(join "", map {"$_\n"} @e) and return if @e;
5373     }
5374     my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
5375
5376     #
5377     # Get the file on local disk
5378     #
5379
5380     my($local_file);
5381     my($local_wanted) =
5382         File::Spec->catfile(
5383                             $CPAN::Config->{keep_source_where},
5384                             "authors",
5385                             "id",
5386                             split(/\//,$self->id)
5387                            );
5388
5389     $self->debug("Doing localize") if $CPAN::DEBUG;
5390     unless ($local_file =
5391             CPAN::FTP->localize("authors/id/$self->{ID}",
5392                                 $local_wanted)) {
5393         my $note = "";
5394         if ($CPAN::Index::DATE_OF_02) {
5395             $note = "Note: Current database in memory was generated ".
5396                 "on $CPAN::Index::DATE_OF_02\n";
5397         }
5398         $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
5399     }
5400
5401     $self->debug("local_wanted[$local_wanted]local_file[$local_file]") if $CPAN::DEBUG;
5402     $self->{localfile} = $local_file;
5403     return if $CPAN::Signal;
5404
5405     #
5406     # Check integrity
5407     #
5408     if ($CPAN::META->has_inst("Digest::SHA")) {
5409         $self->debug("Digest::SHA is installed, verifying");
5410         $self->verifyCHECKSUM;
5411     } else {
5412         $self->debug("Digest::SHA is NOT installed");
5413     }
5414     return if $CPAN::Signal;
5415
5416     #
5417     # Create a clean room and go there
5418     #
5419     $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
5420     my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
5421     $self->safe_chdir($builddir);
5422     $self->debug("Removing tmp-$$") if $CPAN::DEBUG;
5423     File::Path::rmtree("tmp-$$");
5424     unless (mkdir "tmp-$$", 0755) {
5425         $CPAN::Frontend->unrecoverable_error(<<EOF);
5426 Couldn't mkdir '$builddir/tmp-$$': $!
5427
5428 Cannot continue: Please find the reason why I cannot make the
5429 directory
5430 $builddir/tmp-$$
5431 and fix the problem, then retry.
5432
5433 EOF
5434     }
5435     if ($CPAN::Signal){
5436         $self->safe_chdir($sub_wd);
5437         return;
5438     }
5439     $self->safe_chdir("tmp-$$");
5440
5441     #
5442     # Unpack the goods
5443     #
5444     my $ct = eval{CPAN::Tarzip->new($local_file)};
5445     unless ($ct) {
5446         $self->{unwrapped} = CPAN::Distrostatus->new("NO");
5447         delete $self->{build_dir};
5448         return;
5449     }
5450     if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i){
5451         $self->{was_uncompressed}++ unless eval{$ct->gtest()};
5452         $self->untar_me($ct);
5453     } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
5454         $self->unzip_me($ct);
5455     } else {
5456         $self->{was_uncompressed}++ unless $ct->gtest();
5457         $local_file = $self->handle_singlefile($local_file);
5458 #    } else {
5459 #       $self->{archived} = "NO";
5460 #        $self->safe_chdir($sub_wd);
5461 #        return;
5462     }
5463
5464     # we are still in the tmp directory!
5465     # Let's check if the package has its own directory.
5466     my $dh = DirHandle->new(File::Spec->curdir)
5467         or Carp::croak("Couldn't opendir .: $!");
5468     my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
5469     $dh->close;
5470     my ($packagedir);
5471     # XXX here we want in each branch File::Temp to protect all build_dir directories
5472     if (CPAN->has_inst("File::Temp")) {
5473         my $tdir_base;
5474         my $from_dir;
5475         my @dirents;
5476         if (@readdir == 1 && -d $readdir[0]) {
5477             $tdir_base = $readdir[0];
5478             $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]);
5479             my $dh2 = DirHandle->new($from_dir)
5480                 or Carp::croak("Couldn't opendir $from_dir: $!");
5481             @dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC??
5482         } else {
5483             my $userid = $self->cpan_userid;
5484             CPAN->debug("userid[$userid]");
5485             if (!$userid or $userid eq "N/A") {
5486                 $userid = "anon";
5487             }
5488             $tdir_base = $userid;
5489             $from_dir = File::Spec->curdir;
5490             @dirents = @readdir;
5491         }
5492         $packagedir = File::Temp::tempdir(
5493                                           "$tdir_base-XXXXXX",
5494                                           DIR => $builddir,
5495                                           CLEANUP => 0,
5496                                          );
5497         my $f;
5498         for $f (@dirents) { # is already without "." and ".."
5499             my $from = File::Spec->catdir($from_dir,$f);
5500             my $to = File::Spec->catdir($packagedir,$f);
5501             unless (File::Copy::move($from,$to)) {
5502                 my $err = $!;
5503                 $from = File::Spec->rel2abs($from);
5504                 Carp::confess("Couldn't move $from to $to: $err");
5505             }
5506         }
5507     } else { # older code below, still better than nothing when there is no File::Temp
5508         my($distdir);
5509         if (@readdir == 1 && -d $readdir[0]) {
5510             $distdir = $readdir[0];
5511             $packagedir = File::Spec->catdir($builddir,$distdir);
5512             $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
5513                 if $CPAN::DEBUG;
5514             -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
5515                                                         "$packagedir\n");
5516             File::Path::rmtree($packagedir);
5517             unless (File::Copy::move($distdir,$packagedir)) {
5518                 $CPAN::Frontend->unrecoverable_error(<<EOF);
5519 Couldn't move '$distdir' to '$packagedir': $!
5520
5521 Cannot continue: Please find the reason why I cannot move
5522 $builddir/tmp-$$/$distdir
5523 to
5524 $packagedir
5525 and fix the problem, then retry
5526
5527 EOF
5528             }
5529             $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
5530                                  $distdir,
5531                                  $packagedir,
5532                                  -e $packagedir,
5533                                  -d $packagedir,
5534                                 )) if $CPAN::DEBUG;
5535         } else {
5536             my $userid = $self->cpan_userid;
5537             CPAN->debug("userid[$userid]");
5538             if (!$userid or $userid eq "N/A") {
5539                 $userid = "anon";
5540             }
5541             my $pragmatic_dir = $userid . '000';
5542             $pragmatic_dir =~ s/\W_//g;
5543             $pragmatic_dir++ while -d "../$pragmatic_dir";
5544             $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
5545             $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
5546             File::Path::mkpath($packagedir);
5547             my($f);
5548             for $f (@readdir) { # is already without "." and ".."
5549                 my $to = File::Spec->catdir($packagedir,$f);
5550                 File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
5551             }
5552         }
5553     }
5554     if ($CPAN::Signal){
5555         $self->safe_chdir($sub_wd);
5556         return;
5557     }
5558
5559     $self->{'build_dir'} = $packagedir;
5560     $self->safe_chdir($builddir);
5561     File::Path::rmtree("tmp-$$");
5562
5563     $self->safe_chdir($packagedir);
5564     $self->_signature_business();
5565     $self->safe_chdir($builddir);
5566     return if $CPAN::Signal;
5567
5568
5569     my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
5570     my($mpl_exists) = -f $mpl;
5571     unless ($mpl_exists) {
5572         # NFS has been reported to have racing problems after the
5573         # renaming of a directory in some environments.
5574         # This trick helps.
5575         $CPAN::Frontend->mysleep(1);
5576         my $mpldh = DirHandle->new($packagedir)
5577             or Carp::croak("Couldn't opendir $packagedir: $!");
5578         $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
5579         $mpldh->close;
5580     }
5581     my $prefer_installer = "eumm"; # eumm|mb
5582     if (-f File::Spec->catfile($packagedir,"Build.PL")) {
5583         if ($mpl_exists) { # they *can* choose
5584             $prefer_installer = CPAN::HandleConfig->prefs_lookup($self,
5585                                                                  q{prefer_installer});
5586         } else {
5587             $prefer_installer = "mb";
5588         }
5589     }
5590     return unless $self->patch;
5591     if (lc($prefer_installer) eq "mb") {
5592         $self->{modulebuild} = 1;
5593     } elsif (! $mpl_exists) {
5594         $self->_edge_cases($mpl,$packagedir,$local_file);
5595     }
5596     if ($self->{build_dir}
5597         &&
5598         $CPAN::Config->{build_dir_reuse}
5599        ) {
5600         $self->store_persistent_state;
5601     }
5602
5603     return $self;
5604 }
5605
5606 #-> CPAN::Distribution::store_persistent_state
5607 sub store_persistent_state {
5608     my($self) = @_;
5609     my $dir = $self->{build_dir};
5610     unless (File::Spec->canonpath(File::Basename::dirname($dir))
5611             eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
5612         $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
5613                                 "will not store persistent state\n");
5614         return;
5615     }
5616     my $file = sprintf "%s.yml", $dir;
5617     CPAN->_yaml_dumpfile(
5618                          $file,
5619                          {
5620                           time => time,
5621                           perl => CPAN::_perl_fingerprint,
5622                           distribution => $self,
5623                          }
5624                         );
5625 }
5626
5627 #-> CPAN::Distribution::patch
5628 sub try_download {
5629     my($self,$patch) = @_;
5630     my $norm = $self->normalize($patch);
5631     my($local_wanted) =
5632         File::Spec->catfile(
5633                             $CPAN::Config->{keep_source_where},
5634                             "authors",
5635                             "id",
5636                             split(/\//,$norm),
5637                             );
5638     $self->debug("Doing localize") if $CPAN::DEBUG;
5639     return CPAN::FTP->localize("authors/id/$norm",
5640                                $local_wanted);
5641 }
5642
5643 #-> CPAN::Distribution::patch
5644 sub patch {
5645     my($self) = @_;
5646     if (my $patches = $self->prefs->{patches}) {
5647         return unless @$patches;
5648         $self->safe_chdir($self->{build_dir});
5649         CPAN->debug("patches[$patches]");
5650         my $patchbin = $CPAN::Config->{patch};
5651         unless ($patchbin && length $patchbin) {
5652             $CPAN::Frontend->mydie("No external patch command configured\n\n".
5653                                    "Please run 'o conf init /patch/'\n\n");
5654         }
5655         unless (MM->maybe_command($patchbin)) {
5656             $CPAN::Frontend->mydie("No external patch command available\n\n".
5657                                    "Please run 'o conf init /patch/'\n\n");
5658         }
5659         $patchbin = CPAN::HandleConfig->safe_quote($patchbin);
5660         local $ENV{PATCH_GET} = 0; # shall replace -g0 which is not
5661                                    # supported everywhere (and then,
5662                                    # not ever necessary there)
5663         my $stdpatchargs = "-N --fuzz=3";
5664         my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches");
5665         $CPAN::Frontend->myprint("Going to apply $countedpatches:\n");
5666         for my $patch (@$patches) {
5667             unless (-f $patch) {
5668                 if (my $trydl = $self->try_download($patch)) {
5669                     $patch = $trydl;
5670                 } else {
5671                     my $fail = "Could not find patch '$patch'";
5672                     $CPAN::Frontend->mywarn("$fail; cannot continue\n");
5673                     $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
5674                     delete $self->{build_dir};
5675                     return;
5676                 }
5677             }
5678             $CPAN::Frontend->myprint("  $patch\n");
5679             my $readfh = CPAN::Tarzip->TIEHANDLE($patch);
5680             my $thispatchargs = join " ", $stdpatchargs, $self->_patch_p_parameter($readfh);
5681             CPAN->debug("thispatchargs[$thispatchargs]") if $CPAN::DEBUG;
5682             $readfh = CPAN::Tarzip->TIEHANDLE($patch);
5683             my $writefh = FileHandle->new;
5684             unless (open $writefh, "|$patchbin $thispatchargs") {
5685                 my $fail = "Could not fork '$patchbin $thispatchargs'";
5686                 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
5687                 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
5688                 delete $self->{build_dir};
5689                 return;
5690             }
5691             while (my $x = $readfh->READLINE) {
5692                 print $writefh $x;
5693             }
5694             unless (close $writefh) {
5695                 my $fail = "Could not apply patch '$patch'";
5696                 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
5697                 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
5698                 delete $self->{build_dir};
5699                 return;
5700             }
5701         }
5702         $self->{patched}++;
5703     }
5704     return 1;
5705 }
5706
5707 sub _patch_p_parameter {
5708     my($self,$fh) = @_;
5709     my $cnt_files   = 0;
5710     my $cnt_p0files = 0;
5711     local($_);
5712     while ($_ = $fh->READLINE) {
5713         next unless /^[\*\+]{3}\s(\S+)/;
5714         my $file = $1;
5715         $cnt_files++;
5716         $cnt_p0files++ if -f $file;
5717         CPAN->debug("file[$file]cnt_files[$cnt_files]cnt_p0files[$cnt_p0files]") if $CPAN::DEBUG;
5718     }
5719     return "-p1" unless $cnt_files;
5720     return $cnt_files==$cnt_p0files ? "-p0" : "-p1";
5721 }
5722
5723 #-> sub CPAN::Distribution::_edge_cases
5724 # with "configure" or "Makefile" or single file scripts
5725 sub _edge_cases {
5726     my($self,$mpl,$packagedir,$local_file) = @_;
5727     $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
5728                          $mpl,
5729                          CPAN::anycwd(),
5730                         )) if $CPAN::DEBUG;
5731     my($configure) = File::Spec->catfile($packagedir,"Configure");
5732     if (-f $configure) {
5733         # do we have anything to do?
5734         $self->{configure} = $configure;
5735     } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
5736         $CPAN::Frontend->mywarn(qq{
5737 Package comes with a Makefile and without a Makefile.PL.
5738 We\'ll try to build it with that Makefile then.
5739 });
5740         $self->{writemakefile} = CPAN::Distrostatus->new("YES");
5741         $CPAN::Frontend->mysleep(2);
5742     } else {
5743         my $cf = $self->called_for || "unknown";
5744         if ($cf =~ m|/|) {
5745             $cf =~ s|.*/||;
5746             $cf =~ s|\W.*||;
5747         }
5748         $cf =~ s|[/\\:]||g;     # risk of filesystem damage
5749         $cf = "unknown" unless length($cf);
5750         $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
5751   (The test -f "$mpl" returned false.)
5752   Writing one on our own (setting NAME to $cf)\a\n});
5753         $self->{had_no_makefile_pl}++;
5754         $CPAN::Frontend->mysleep(3);
5755
5756         # Writing our own Makefile.PL
5757
5758         my $script = "";
5759         if ($self->{archived} eq "maybe_pl") {
5760             my $fh = FileHandle->new;
5761             my $script_file = File::Spec->catfile($packagedir,$local_file);
5762             $fh->open($script_file)
5763                 or Carp::croak("Could not open $script_file: $!");
5764             local $/ = "\n";
5765             # name parsen und prereq
5766             my($state) = "poddir";
5767             my($name, $prereq) = ("", "");
5768             while (<$fh>) {
5769                 if ($state eq "poddir" && /^=head\d\s+(\S+)/) {
5770                     if ($1 eq 'NAME') {
5771                         $state = "name";
5772                     } elsif ($1 eq 'PREREQUISITES') {
5773                         $state = "prereq";
5774                     }
5775                 } elsif ($state =~ m{^(name|prereq)$}) {
5776                     if (/^=/) {
5777                         $state = "poddir";
5778                     } elsif (/^\s*$/) {
5779                         # nop
5780                     } elsif ($state eq "name") {
5781                         if ($name eq "") {
5782                             ($name) = /^(\S+)/;
5783                             $state = "poddir";
5784                         }
5785                     } elsif ($state eq "prereq") {
5786                         $prereq .= $_;
5787                     }
5788                 } elsif (/^=cut\b/) {
5789                     last;
5790                 }
5791             }
5792             $fh->close;
5793
5794             for ($name) {
5795                 s{.*<}{};       # strip X<...>
5796                 s{>.*}{};
5797             }
5798             chomp $prereq;
5799             $prereq = join " ", split /\s+/, $prereq;
5800             my($PREREQ_PM) = join("\n", map {
5801                 s{.*<}{};       # strip X<...>
5802                 s{>.*}{};
5803                 if (/[\s\'\"]/) { # prose?
5804                 } else {
5805                     s/[^\w:]$//; # period?
5806                     " "x28 . "'$_' => 0,";
5807                 }
5808             } split /\s*,\s*/, $prereq);
5809
5810             $script = "
5811               EXE_FILES => ['$name'],
5812               PREREQ_PM => {
5813 $PREREQ_PM
5814                            },
5815 ";
5816             if ($name) {
5817                 my $to_file = File::Spec->catfile($packagedir, $name);
5818                 rename $script_file, $to_file
5819                     or die "Can't rename $script_file to $to_file: $!";
5820             }
5821         }
5822
5823         my $fh = FileHandle->new;
5824         $fh->open(">$mpl")
5825             or Carp::croak("Could not open >$mpl: $!");
5826         $fh->print(
5827                    qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
5828 # because there was no Makefile.PL supplied.
5829 # Autogenerated on: }.scalar localtime().qq{
5830
5831 use ExtUtils::MakeMaker;
5832 WriteMakefile(
5833               NAME => q[$cf],$script
5834              );
5835 });
5836         $fh->close;
5837     }
5838 }
5839
5840 #-> CPAN::Distribution::_signature_business
5841 sub _signature_business {
5842     my($self) = @_;
5843     my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
5844                                                       q{check_sigs});
5845     if ($check_sigs) {
5846         if ($CPAN::META->has_inst("Module::Signature")) {
5847             if (-f "SIGNATURE") {
5848                 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
5849                 my $rv = Module::Signature::verify();
5850                 if ($rv != Module::Signature::SIGNATURE_OK() and
5851                     $rv != Module::Signature::SIGNATURE_MISSING()) {
5852                     $CPAN::Frontend->mywarn(
5853                                             qq{\nSignature invalid for }.
5854                                             qq{distribution file. }.
5855                                             qq{Please investigate.\n\n}
5856                                            );
5857
5858                     my $wrap =
5859                         sprintf(qq{I'd recommend removing %s. Its signature
5860 is invalid. Maybe you have configured your 'urllist' with
5861 a bad URL. Please check this array with 'o conf urllist', and
5862 retry. For more information, try opening a subshell with
5863   look %s
5864 and there run
5865   cpansign -v
5866 },
5867                                 $self->{localfile},
5868                                 $self->pretty_id,
5869                                );
5870                     $self->{signature_verify} = CPAN::Distrostatus->new("NO");
5871                     $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
5872                     $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
5873                 } else {
5874                     $self->{signature_verify} = CPAN::Distrostatus->new("YES");
5875                     $self->debug("Module::Signature has verified") if $CPAN::DEBUG;
5876                 }
5877             } else {
5878                 $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n});
5879             }
5880         } else {
5881             $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
5882         }
5883     }
5884 }
5885
5886 #-> CPAN::Distribution::untar_me ;
5887 sub untar_me {
5888     my($self,$ct) = @_;
5889     $self->{archived} = "tar";
5890     if ($ct->untar()) {
5891         $self->{unwrapped} = CPAN::Distrostatus->new("YES");
5892     } else {
5893         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed");
5894     }
5895 }
5896
5897 # CPAN::Distribution::unzip_me ;
5898 sub unzip_me {
5899     my($self,$ct) = @_;
5900     $self->{archived} = "zip";
5901     if ($ct->unzip()) {
5902         $self->{unwrapped} = CPAN::Distrostatus->new("YES");
5903     } else {
5904         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed");
5905     }
5906     return;
5907 }
5908
5909 sub handle_singlefile {
5910     my($self,$local_file) = @_;
5911
5912     if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ){
5913         $self->{archived} = "pm";
5914     } else {
5915         $self->{archived} = "maybe_pl";
5916     }
5917
5918     my $to = File::Basename::basename($local_file);
5919     if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
5920         if (eval{CPAN::Tarzip->new($local_file)->gunzip($to)}) {
5921             $self->{unwrapped} = CPAN::Distrostatus->new("YES");
5922         } else {
5923             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- uncompressing failed");
5924         }
5925     } else {
5926         File::Copy::cp($local_file,".");
5927         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed");
5928     }
5929     return $to;
5930 }
5931
5932 #-> sub CPAN::Distribution::new ;
5933 sub new {
5934     my($class,%att) = @_;
5935
5936     # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
5937
5938     my $this = { %att };
5939     return bless $this, $class;
5940 }
5941
5942 #-> sub CPAN::Distribution::look ;
5943 sub look {
5944     my($self) = @_;
5945
5946     if ($^O eq 'MacOS') {
5947       $self->Mac::BuildTools::look;
5948       return;
5949     }
5950
5951     if (  $CPAN::Config->{'shell'} ) {
5952         $CPAN::Frontend->myprint(qq{
5953 Trying to open a subshell in the build directory...
5954 });
5955     } else {
5956         $CPAN::Frontend->myprint(qq{
5957 Your configuration does not define a value for subshells.
5958 Please define it with "o conf shell <your shell>"
5959 });
5960         return;
5961     }
5962     my $dist = $self->id;
5963     my $dir;
5964     unless ($dir = $self->dir) {
5965         $self->get;
5966     }
5967     unless ($dir ||= $self->dir) {
5968         $CPAN::Frontend->mywarn(qq{
5969 Could not determine which directory to use for looking at $dist.
5970 });
5971         return;
5972     }
5973     my $pwd  = CPAN::anycwd();
5974     $self->safe_chdir($dir);
5975     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
5976     {
5977         local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
5978         $ENV{CPAN_SHELL_LEVEL} += 1;
5979         my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'});
5980         unless (system($shell) == 0) {
5981             my $code = $? >> 8;
5982             $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
5983         }
5984     }
5985     $self->safe_chdir($pwd);
5986 }
5987
5988 # CPAN::Distribution::cvs_import ;
5989 sub cvs_import {
5990     my($self) = @_;
5991     $self->get;
5992     my $dir = $self->dir;
5993
5994     my $package = $self->called_for;
5995     my $module = $CPAN::META->instance('CPAN::Module', $package);
5996     my $version = $module->cpan_version;
5997
5998     my $userid = $self->cpan_userid;
5999
6000     my $cvs_dir = (split /\//, $dir)[-1];
6001     $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
6002     my $cvs_root =
6003       $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
6004     my $cvs_site_perl =
6005       $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
6006     if ($cvs_site_perl) {
6007         $cvs_dir = "$cvs_site_perl/$cvs_dir";
6008     }
6009     my $cvs_log = qq{"imported $package $version sources"};
6010     $version =~ s/\./_/g;
6011     # XXX cvs: undocumented and unclear how it was meant to work
6012     my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
6013                "$cvs_dir", $userid, "v$version");
6014
6015     my $pwd  = CPAN::anycwd();
6016     chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
6017
6018     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
6019
6020     $CPAN::Frontend->myprint(qq{@cmd\n});
6021     system(@cmd) == 0 or
6022     # XXX cvs
6023         $CPAN::Frontend->mydie("cvs import failed");
6024     chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
6025 }
6026
6027 #-> sub CPAN::Distribution::readme ;
6028 sub readme {
6029     my($self) = @_;
6030     my($dist) = $self->id;
6031     my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
6032     $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
6033     my($local_file);
6034     my($local_wanted) =
6035          File::Spec->catfile(
6036                              $CPAN::Config->{keep_source_where},
6037                              "authors",
6038                              "id",
6039                              split(/\//,"$sans.readme"),
6040                             );
6041     $self->debug("Doing localize") if $CPAN::DEBUG;
6042     $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
6043                                       $local_wanted)
6044         or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
6045
6046     if ($^O eq 'MacOS') {
6047         Mac::BuildTools::launch_file($local_file);
6048         return;
6049     }
6050
6051     my $fh_pager = FileHandle->new;
6052     local($SIG{PIPE}) = "IGNORE";
6053     my $pager = $CPAN::Config->{'pager'} || "cat";
6054     $fh_pager->open("|$pager")
6055         or die "Could not open pager $pager\: $!";
6056     my $fh_readme = FileHandle->new;
6057     $fh_readme->open($local_file)
6058         or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
6059     $CPAN::Frontend->myprint(qq{
6060 Displaying file
6061   $local_file
6062 with pager "$pager"
6063 });
6064     $fh_pager->print(<$fh_readme>);
6065     $fh_pager->close;
6066 }
6067
6068 #-> sub CPAN::Distribution::verifyCHECKSUM ;
6069 sub verifyCHECKSUM {
6070     my($self) = @_;
6071   EXCUSE: {
6072         my @e;
6073         $self->{CHECKSUM_STATUS} ||= "";
6074         $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
6075         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
6076     }
6077     my($lc_want,$lc_file,@local,$basename);
6078     @local = split(/\//,$self->id);
6079     pop @local;
6080     push @local, "CHECKSUMS";
6081     $lc_want =
6082         File::Spec->catfile($CPAN::Config->{keep_source_where},
6083                             "authors", "id", @local);
6084     local($") = "/";
6085     if (my $size = -s $lc_want) {
6086         $self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG;
6087         if ($self->CHECKSUM_check_file($lc_want,1)) {
6088             return $self->{CHECKSUM_STATUS} = "OK";
6089         }
6090     }
6091     $lc_file = CPAN::FTP->localize("authors/id/@local",
6092                                    $lc_want,1);
6093     unless ($lc_file) {
6094         $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
6095         $local[-1] .= ".gz";
6096         $lc_file = CPAN::FTP->localize("authors/id/@local",
6097                                        "$lc_want.gz",1);
6098         if ($lc_file) {
6099             $lc_file =~ s/\.gz(?!\n)\Z//;
6100             eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
6101         } else {
6102             return;
6103         }
6104     }
6105     if ($self->CHECKSUM_check_file($lc_file)) {
6106         return $self->{CHECKSUM_STATUS} = "OK";
6107     }
6108 }
6109
6110 #-> sub CPAN::Distribution::SIG_check_file ;
6111 sub SIG_check_file {
6112     my($self,$chk_file) = @_;
6113     my $rv = eval { Module::Signature::_verify($chk_file) };
6114
6115     if ($rv == Module::Signature::SIGNATURE_OK()) {
6116         $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
6117         return $self->{SIG_STATUS} = "OK";
6118     } else {
6119         $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
6120                                  qq{distribution file. }.
6121                                  qq{Please investigate.\n\n}.
6122                                  $self->as_string,
6123                                 $CPAN::META->instance(
6124                                                         'CPAN::Author',
6125                                                         $self->cpan_userid
6126                                                         )->as_string);
6127
6128         my $wrap = qq{I\'d recommend removing $chk_file. Its signature
6129 is invalid. Maybe you have configured your 'urllist' with
6130 a bad URL. Please check this array with 'o conf urllist', and
6131 retry.};
6132
6133         $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
6134     }
6135 }
6136
6137 #-> sub CPAN::Distribution::CHECKSUM_check_file ;
6138
6139 # sloppy is 1 when we have an old checksums file that maybe is good
6140 # enough
6141
6142 sub CHECKSUM_check_file {
6143     my($self,$chk_file,$sloppy) = @_;
6144     my($cksum,$file,$basename);
6145
6146     $sloppy ||= 0;
6147     $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG;
6148     my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
6149                                                       q{check_sigs});
6150     if ($check_sigs) {
6151         if ($CPAN::META->has_inst("Module::Signature")) {
6152             $self->debug("Module::Signature is installed, verifying");
6153             $self->SIG_check_file($chk_file);
6154         } else {
6155             $self->debug("Module::Signature is NOT installed");
6156         }
6157     }
6158
6159     $file = $self->{localfile};
6160     $basename = File::Basename::basename($file);
6161     my $fh = FileHandle->new;
6162     if (open $fh, $chk_file){
6163         local($/);
6164         my $eval = <$fh>;
6165         $eval =~ s/\015?\012/\n/g;
6166         close $fh;
6167         my($comp) = Safe->new();
6168         $cksum = $comp->reval($eval);
6169         if ($@) {
6170             rename $chk_file, "$chk_file.bad";
6171             Carp::confess($@) if $@;
6172         }
6173     } else {
6174         Carp::carp "Could not open $chk_file for reading";
6175     }
6176
6177     if (! ref $cksum or ref $cksum ne "HASH") {
6178         $CPAN::Frontend->mywarn(qq{
6179 Warning: checksum file '$chk_file' broken.
6180
6181 When trying to read that file I expected to get a hash reference
6182 for further processing, but got garbage instead.
6183 });
6184         my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
6185         $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
6186         $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken";
6187         return;
6188     } elsif (exists $cksum->{$basename}{sha256}) {
6189         $self->debug("Found checksum for $basename:" .
6190                      "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
6191
6192         open($fh, $file);
6193         binmode $fh;
6194         my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
6195         $fh->close;
6196         $fh = CPAN::Tarzip->TIEHANDLE($file);
6197
6198         unless ($eq) {
6199           my $dg = Digest::SHA->new(256);
6200           my($data,$ref);
6201           $ref = \$data;
6202           while ($fh->READ($ref, 4096) > 0){
6203             $dg->add($data);
6204           }
6205           my $hexdigest = $dg->hexdigest;
6206           $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
6207         }
6208
6209         if ($eq) {
6210           $CPAN::Frontend->myprint("Checksum for $file ok\n");
6211           return $self->{CHECKSUM_STATUS} = "OK";
6212         } else {
6213             $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
6214                                      qq{distribution file. }.
6215                                      qq{Please investigate.\n\n}.
6216                                      $self->as_string,
6217                                      $CPAN::META->instance(
6218                                                            'CPAN::Author',
6219                                                            $self->cpan_userid
6220                                                           )->as_string);
6221
6222             my $wrap = qq{I\'d recommend removing $file. Its
6223 checksum is incorrect. Maybe you have configured your 'urllist' with
6224 a bad URL. Please check this array with 'o conf urllist', and
6225 retry.};
6226
6227             $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
6228
6229             # former versions just returned here but this seems a
6230             # serious threat that deserves a die
6231
6232             # $CPAN::Frontend->myprint("\n\n");
6233             # sleep 3;
6234             # return;
6235         }
6236         # close $fh if fileno($fh);
6237     } else {
6238         return if $sloppy;
6239         unless ($self->{CHECKSUM_STATUS}) {
6240             $CPAN::Frontend->mywarn(qq{
6241 Warning: No checksum for $basename in $chk_file.
6242
6243 The cause for this may be that the file is very new and the checksum
6244 has not yet been calculated, but it may also be that something is
6245 going awry right now.
6246 });
6247             my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes");
6248             $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
6249         }
6250         $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file";
6251         return;
6252     }
6253 }
6254
6255 #-> sub CPAN::Distribution::eq_CHECKSUM ;
6256 sub eq_CHECKSUM {
6257     my($self,$fh,$expect) = @_;
6258     if ($CPAN::META->has_inst("Digest::SHA")) {
6259         my $dg = Digest::SHA->new(256);
6260         my($data);
6261         while (read($fh, $data, 4096)){
6262             $dg->add($data);
6263         }
6264         my $hexdigest = $dg->hexdigest;
6265         # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
6266         return $hexdigest eq $expect;
6267     }
6268     return 1;
6269 }
6270
6271 #-> sub CPAN::Distribution::force ;
6272
6273 # Both CPAN::Modules and CPAN::Distributions know if "force" is in
6274 # effect by autoinspection, not by inspecting a global variable. One
6275 # of the reason why this was chosen to work that way was the treatment
6276 # of dependencies. They should not automatically inherit the force
6277 # status. But this has the downside that ^C and die() will return to
6278 # the prompt but will not be able to reset the force_update
6279 # attributes. We try to correct for it currently in the read_metadata
6280 # routine, and immediately before we check for a Signal. I hope this
6281 # works out in one of v1.57_53ff
6282
6283 # "Force get forgets previous error conditions"
6284
6285 #-> sub CPAN::Distribution::force ;
6286 sub force {
6287   my($self, $method) = @_;
6288   my %phase_map = (
6289                    get => [
6290                            "unwrapped",
6291                            "build_dir",
6292                            "archived",
6293                            "localfile",
6294                            "CHECKSUM_STATUS",
6295                            "signature_verify",
6296                            "prefs",
6297                            "prefs_file",
6298                            "prefs_file_doc",
6299                           ],
6300                    make => [
6301                             "writemakefile",
6302                             "make",
6303                             "modulebuild",
6304                             "prereq_pm",
6305                             "prereq_pm_detected",
6306                            ],
6307                    test => [
6308                             "badtestcnt",
6309                             "make_test",
6310                            ],
6311                    install => [
6312                                "install",
6313                               ],
6314                    unknown => [
6315                                "reqtype",
6316                                "yaml_content",
6317                               ],
6318                   );
6319  PHASE: for my $phase (qw(get make test install unknown)) { # tentative
6320     ATTRIBUTE: for my $att (@{$phase_map{$phase}}) {
6321           if ($phase eq "get" && $self->id =~ /\.$/ && $att =~ /(unwrapped|build_dir)/ ) {
6322               # cannot be undone for local distros
6323               next ATTRIBUTE;
6324           }
6325           delete $self->{$att};
6326           CPAN->debug(sprintf "phase[%s]att[%s]", $phase, $att) if $CPAN::DEBUG;
6327       }
6328   }
6329   if ($method && $method =~ /make|test|install/) {
6330     $self->{"force_update"}++; # name should probably have been force_install
6331   }
6332 }
6333
6334 #-> sub CPAN::Distribution::notest ;
6335 sub notest {
6336   my($self, $method) = @_;
6337   # warn "XDEBUG: set notest for $self $method";
6338   $self->{"notest"}++; # name should probably have been force_install
6339 }
6340
6341 #-> sub CPAN::Distribution::unnotest ;
6342 sub unnotest {
6343   my($self) = @_;
6344   # warn "XDEBUG: deleting notest";
6345   delete $self->{'notest'};
6346 }
6347
6348 #-> sub CPAN::Distribution::unforce ;
6349 sub unforce {
6350   my($self) = @_;
6351   delete $self->{'force_update'};
6352 }
6353
6354 #-> sub CPAN::Distribution::isa_perl ;
6355 sub isa_perl {
6356   my($self) = @_;
6357   my $file = File::Basename::basename($self->id);
6358   if ($file =~ m{ ^ perl
6359                   -?
6360                   (5)
6361                   ([._-])
6362                   (
6363                    \d{3}(_[0-4][0-9])?
6364                    |
6365                    \d+\.\d+
6366                   )
6367                   \.tar[._-](?:gz|bz2)
6368                   (?!\n)\Z
6369                 }xs){
6370     return "$1.$3";
6371   } elsif ($self->cpan_comment
6372            &&
6373            $self->cpan_comment =~ /isa_perl\(.+?\)/){
6374     return $1;
6375   }
6376 }
6377
6378
6379 #-> sub CPAN::Distribution::perl ;
6380 sub perl {
6381     my ($self) = @_;
6382     if (! $self) {
6383         use Carp qw(carp);
6384         carp __PACKAGE__ . "::perl was called without parameters.";
6385     }
6386     return CPAN::HandleConfig->safe_quote($CPAN::Perl);
6387 }
6388
6389
6390 #-> sub CPAN::Distribution::make ;
6391 sub make {
6392     my($self) = @_;
6393     if (my $goto = $self->prefs->{goto}) {
6394         return $self->goto($goto);
6395     }
6396     my $make = $self->{modulebuild} ? "Build" : "make";
6397     # Emergency brake if they said install Pippi and get newest perl
6398     if ($self->isa_perl) {
6399       if (
6400           $self->called_for ne $self->id &&
6401           ! $self->{force_update}
6402          ) {
6403         # if we die here, we break bundles
6404         $CPAN::Frontend
6405             ->mywarn(sprintf(
6406                              qq{The most recent version "%s" of the module "%s"
6407 is part of the perl-%s distribution. To install that, you need to run
6408   force install %s   --or--
6409   install %s
6410 },
6411                              $CPAN::META->instance(
6412                                                    'CPAN::Module',
6413                                                    $self->called_for
6414                                                   )->cpan_version,
6415                              $self->called_for,
6416                              $self->isa_perl,
6417                              $self->called_for,
6418                              $self->id,
6419                             ));
6420         $self->{make} = CPAN::Distrostatus->new("NO isa perl");
6421         $CPAN::Frontend->mysleep(1);
6422         return;
6423       }
6424     }
6425     $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
6426     $self->get;
6427     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
6428                            ? $ENV{PERL5LIB}
6429                            : ($ENV{PERLLIB} || "");
6430
6431     $CPAN::META->set_perl5lib;
6432     local $ENV{MAKEFLAGS}; # protect us from outer make calls
6433
6434     if ($CPAN::Signal){
6435       delete $self->{force_update};
6436       return;
6437     }
6438   EXCUSE: {
6439         my @e;
6440         if (!$self->{archived} || $self->{archived} eq "NO") {
6441             push @e, "Is neither a tar nor a zip archive.";
6442         }
6443
6444         if (!$self->{unwrapped}
6445             || (
6446                 UNIVERSAL::can($self->{unwrapped},"failed") ?
6447                 $self->{unwrapped}->failed :
6448                 $self->{unwrapped} =~ /^NO/
6449                )) {
6450             push @e, "Had problems unarchiving. Please build manually";
6451         }
6452
6453         unless ($self->{force_update}) {
6454             exists $self->{signature_verify} and
6455                 (
6456                  UNIVERSAL::can($self->{signature_verify},"failed") ?
6457                  $self->{signature_verify}->failed :
6458                  $self->{signature_verify} =~ /^NO/
6459                 )
6460                 and push @e, "Did not pass the signature test.";
6461         }
6462
6463         if (exists $self->{writemakefile} &&
6464             (
6465              UNIVERSAL::can($self->{writemakefile},"failed") ?
6466              $self->{writemakefile}->failed :
6467              $self->{writemakefile} =~ /^NO/
6468             )) {
6469             # XXX maybe a retry would be in order?
6470             my $err = UNIVERSAL::can($self->{writemakefile},"text") ?
6471                 $self->{writemakefile}->text :
6472                     $self->{writemakefile};
6473             $err =~ s/^NO\s*//;
6474             $err ||= "Had some problem writing Makefile";
6475             $err .= ", won't make";
6476             push @e, $err;
6477         }
6478
6479         defined $self->{make} and push @e,
6480             "Has already been processed within this session";
6481
6482         if (exists $self->{later} and length($self->{later})) {
6483             if ($self->unsat_prereq) {
6484                 push @e, $self->{later};
6485 # RT ticket 18438 raises doubts if the deletion of {later} is valid.
6486 # YAML-0.53 triggered the later hodge-podge here, but my margin notes
6487 # are not sufficient to be sure if we really must/may do the delete
6488 # here. SO I accept the suggested patch for now. If we trigger a bug
6489 # again, I must go into deep contemplation about the {later} flag.
6490
6491 #            } else {
6492 #                delete $self->{later};
6493             }
6494         }
6495
6496         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
6497     }
6498     if ($CPAN::Signal){
6499       delete $self->{force_update};
6500       return;
6501     }
6502     $CPAN::Frontend->myprint("\n  CPAN.pm: Going to build ".$self->id."\n\n");
6503     my $builddir = $self->dir or
6504         $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
6505     chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
6506     $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
6507
6508     if ($^O eq 'MacOS') {
6509         Mac::BuildTools::make($self);
6510         return;
6511     }
6512
6513     my %env;
6514     while (my($k,$v) = each %ENV) {
6515         next unless defined $v;
6516         $env{$k} = $v;
6517     }
6518     local %ENV = %env;
6519     my $system;
6520     if (my $commandline = $self->prefs->{pl}{commandline}) {
6521         $system = $commandline;
6522         $ENV{PERL} = $^X;
6523     } elsif ($self->{'configure'}) {
6524         $system = $self->{'configure'};
6525     } elsif ($self->{modulebuild}) {
6526         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
6527         $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}";
6528     } else {
6529         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
6530         my $switch = "";
6531 # This needs a handler that can be turned on or off:
6532 #       $switch = "-MExtUtils::MakeMaker ".
6533 #           "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
6534 #           if $] > 5.00310;
6535         my $makepl_arg = $self->make_x_arg("pl");
6536         $system = sprintf("%s%s Makefile.PL%s",
6537                           $perl,
6538                           $switch ? " $switch" : "",
6539                           $makepl_arg ? " $makepl_arg" : "",
6540                          );
6541     }
6542     if (my $env = $self->prefs->{pl}{env}) {
6543         for my $e (keys %$env) {
6544             $ENV{$e} = $env->{$e};
6545         }
6546     }
6547     if (exists $self->{writemakefile}) {
6548     } else {
6549         local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
6550         my($ret,$pid);
6551         $@ = "";
6552         my $go_via_alarm;
6553         if ($CPAN::Config->{inactivity_timeout}) {
6554             require Config;
6555             if ($Config::Config{d_alarm}
6556                 &&
6557                 $Config::Config{d_alarm} eq "define"
6558                ) {
6559                 $go_via_alarm++
6560             } else {
6561                 $CPAN::Frontend->mywarn("Warning: you have configured the config ".
6562                                         "variable 'inactivity_timeout' to ".
6563                                         "'$CPAN::Config->{inactivity_timeout}'. But ".
6564                                         "on this machine the system call 'alarm' ".
6565                                         "isn't available. This means that we cannot ".
6566                                         "provide the feature of intercepting long ".
6567                                         "waiting code and will turn this feature off.\n"
6568                                        );
6569                 $CPAN::Config->{inactivity_timeout} = 0;
6570             }
6571         }
6572         if ($go_via_alarm) {
6573             eval {
6574                 alarm $CPAN::Config->{inactivity_timeout};
6575                 local $SIG{CHLD}; # = sub { wait };
6576                 if (defined($pid = fork)) {
6577                     if ($pid) { #parent
6578                         # wait;
6579                         waitpid $pid, 0;
6580                     } else {    #child
6581                         # note, this exec isn't necessary if
6582                         # inactivity_timeout is 0. On the Mac I'd
6583                         # suggest, we set it always to 0.
6584                         exec $system;
6585                     }
6586                 } else {
6587                     $CPAN::Frontend->myprint("Cannot fork: $!");
6588                     return;
6589                 }
6590             };
6591             alarm 0;
6592             if ($@){
6593                 kill 9, $pid;
6594                 waitpid $pid, 0;
6595                 my $err = "$@";
6596                 $CPAN::Frontend->myprint($err);
6597                 $self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
6598                 $@ = "";
6599                 return;
6600             }
6601         } else {
6602             if (my $expect_model = $self->_prefs_with_expect("pl")) {
6603                 $ret = $self->_run_via_expect($system,$expect_model);
6604                 if (! defined $ret
6605                     && $self->{writemakefile}
6606                     && $self->{writemakefile}->failed) {
6607                     # timeout
6608                     return;
6609                 }
6610             } else {
6611                 $ret = system($system);
6612             }
6613             if ($ret != 0) {
6614                 $self->{writemakefile} = CPAN::Distrostatus
6615                     ->new("NO '$system' returned status $ret");
6616                 $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
6617                 $self->store_persistent_state;
6618                 $self->store_persistent_state;
6619                 return;
6620             }
6621         }
6622         if (-f "Makefile" || -f "Build") {
6623           $self->{writemakefile} = CPAN::Distrostatus->new("YES");
6624           delete $self->{make_clean}; # if cleaned before, enable next
6625         } else {
6626           $self->{writemakefile} = CPAN::Distrostatus
6627               ->new(qq{NO -- Unknown reason});
6628         }
6629     }
6630     if ($CPAN::Signal){
6631       delete $self->{force_update};
6632       return;
6633     }
6634     if (my @prereq = $self->unsat_prereq){
6635         if ($prereq[0][0] eq "perl") {
6636             my $need = "requires perl '$prereq[0][1]'";
6637             my $id = $self->pretty_id;
6638             $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
6639             $self->{make} = CPAN::Distrostatus->new("NO $need");
6640             $self->store_persistent_state;
6641             return;
6642         } else {
6643             return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
6644         }
6645     }
6646     if ($CPAN::Signal){
6647       delete $self->{force_update};
6648       return;
6649     }
6650     if (my $commandline = $self->prefs->{make}{commandline}) {
6651         $system = $commandline;
6652         $ENV{PERL} = $^X;
6653     } else {
6654         if ($self->{modulebuild}) {
6655             unless (-f "Build") {
6656                 my $cwd = CPAN::anycwd();
6657                 $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
6658                                         " in cwd[$cwd]. Danger, Will Robinson!");
6659                 $CPAN::Frontend->mysleep(5);
6660             }
6661             $system = sprintf "%s %s", $self->_build_command(), $CPAN::Config->{mbuild_arg};
6662         } else {
6663             $system = join " ", $self->_make_command(), $CPAN::Config->{make_arg};
6664         }
6665         my $make_arg = $self->make_x_arg("make");
6666         $system = sprintf("%s%s",
6667                           $system,
6668                           $make_arg ? " $make_arg" : "",
6669                          );
6670     }
6671     if (my $env = $self->prefs->{make}{env}) { # overriding the local
6672                                                # ENV of PL, not the
6673                                                # outer ENV, but
6674                                                # unlikely to be a risk
6675         for my $e (keys %$env) {
6676             $ENV{$e} = $env->{$e};
6677         }
6678     }
6679     my $expect_model = $self->_prefs_with_expect("make");
6680     my $want_expect = 0;
6681     if ( $expect_model && @{$expect_model->{talk}} ) {
6682         my $can_expect = $CPAN::META->has_inst("Expect");
6683         if ($can_expect) {
6684             $want_expect = 1;
6685         } else {
6686             $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
6687                                     "system()\n");
6688         }
6689     }
6690     my $system_ok;
6691     if ($want_expect) {
6692         $system_ok = $self->_run_via_expect($system,$expect_model) == 0;
6693     } else {
6694         $system_ok = system($system) == 0;
6695     }
6696     $self->introduce_myself;
6697     if ( $system_ok ) {
6698          $CPAN::Frontend->myprint("  $system -- OK\n");
6699          $self->{make} = CPAN::Distrostatus->new("YES");
6700     } else {
6701          $self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
6702          $self->{make} = CPAN::Distrostatus->new("NO");
6703          $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
6704     }
6705     $self->store_persistent_state;
6706 }
6707
6708 # CPAN::Distribution::_run_via_expect
6709 sub _run_via_expect {
6710     my($self,$system,$expect_model) = @_;
6711     CPAN->debug("system[$system]expect_model[$expect_model]") if $CPAN::DEBUG;
6712     if ($CPAN::META->has_inst("Expect")) {
6713         my $expo = Expect->new;  # expo Expect object;
6714         $expo->spawn($system);
6715         $expect_model->{mode} ||= "deterministic";
6716         if ($expect_model->{mode} eq "deterministic") {
6717             return $self->_run_via_expect_deterministic($expo,$expect_model);
6718         } elsif ($expect_model->{mode} eq "anyorder") {
6719             return $self->_run_via_expect_anyorder($expo,$expect_model);
6720         } else {
6721             die "Panic: Illegal expect mode: $expect_model->{mode}";
6722         }
6723     } else {
6724         $CPAN::Frontend->mywarn("Expect not installed, falling back to system()\n");
6725         return system($system);
6726     }
6727 }
6728
6729 sub _run_via_expect_anyorder {
6730     my($self,$expo,$expect_model) = @_;
6731     my $timeout = $expect_model->{timeout} || 5;
6732     my @expectacopy = @{$expect_model->{talk}}; # we trash it!
6733     my $but = "";
6734   EXPECT: while () {
6735         my($eof,$ran_into_timeout);
6736         my @match = $expo->expect($timeout,
6737                                   [ eof => sub {
6738                                         $eof++;
6739                                     } ],
6740                                   [ timeout => sub {
6741                                         $ran_into_timeout++;
6742                                     } ],
6743                                   -re => eval"qr{.}",
6744                                  );
6745         if ($match[2]) {
6746             $but .= $match[2];
6747         }
6748         $but .= $expo->clear_accum;
6749         if ($eof) {
6750             $expo->soft_close;
6751             return $expo->exitstatus();
6752         } elsif ($ran_into_timeout) {
6753             # warn "DEBUG: they are asking a question, but[$but]";
6754             for (my $i = 0; $i <= $#expectacopy; $i+=2) {
6755                 my($next,$send) = @expectacopy[$i,$i+1];
6756                 my $regex = eval "qr{$next}";
6757                 # warn "DEBUG: will compare with regex[$regex].";
6758                 if ($but =~ /$regex/) {
6759                     # warn "DEBUG: will send send[$send]";
6760                     $expo->send($send);
6761                     splice @expectacopy, $i, 2; # never allow reusing an QA pair
6762                     next EXPECT;
6763                 }
6764             }
6765             my $why = "could not answer a question during the dialog";
6766             $CPAN::Frontend->mywarn("Failing: $why\n");
6767             $self->{writemakefile} =
6768                 CPAN::Distrostatus->new("NO $why");
6769             return;
6770         }
6771     }
6772 }
6773
6774 sub _run_via_expect_deterministic {
6775     my($self,$expo,$expect_model) = @_;
6776     my $ran_into_timeout;
6777     my $timeout = $expect_model->{timeout} || 15; # currently unsettable
6778     my $expecta = $expect_model->{talk};
6779   EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) {
6780         my($re,$send) = @$expecta[$i,$i+1];
6781         CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG;
6782         my $regex = eval "qr{$re}";
6783         $expo->expect($timeout,
6784                       [ eof => sub {
6785                             my $but = $expo->clear_accum;
6786                             $CPAN::Frontend->mywarn("EOF (maybe harmless)
6787 expected[$regex]\nbut[$but]\n\n");
6788                             last EXPECT;
6789                         } ],
6790                       [ timeout => sub {
6791                             my $but = $expo->clear_accum;
6792                             $CPAN::Frontend->mywarn("TIMEOUT
6793 expected[$regex]\nbut[$but]\n\n");
6794                             $ran_into_timeout++;
6795                         } ],
6796                       -re => $regex);
6797         if ($ran_into_timeout){
6798             # note that the caller expects 0 for success
6799             $self->{writemakefile} =
6800                 CPAN::Distrostatus->new("NO timeout during expect dialog");
6801             return;
6802         }
6803         $expo->send($send);
6804     }
6805     $expo->soft_close;
6806     return $expo->exitstatus();
6807 }
6808
6809 sub _validate_distropref {
6810     my($self,@args) = @_;
6811     if (
6812         $CPAN::META->has_inst("CPAN::Kwalify")
6813         &&
6814         $CPAN::META->has_inst("Kwalify")
6815        ) {
6816         eval {CPAN::Kwalify::_validate("distroprefs",@args);};
6817         if ($@) {
6818             $CPAN::Frontend->mywarn($@);
6819         }
6820     } else {
6821         CPAN->debug("not validating '@args'") if $CPAN::DEBUG;
6822     }
6823 }
6824
6825 # CPAN::Distribution::_find_prefs
6826 sub _find_prefs {
6827     my($self) = @_;
6828     my $distroid = $self->pretty_id;
6829     CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG;
6830     my $prefs_dir = $CPAN::Config->{prefs_dir};
6831     eval { File::Path::mkpath($prefs_dir); };
6832     if ($@) {
6833         $CPAN::Frontend->mydie("Cannot create directory $prefs_dir");
6834     }
6835     my $yaml_module = CPAN->_yaml_module;
6836     my @extensions;
6837     if ($CPAN::META->has_inst($yaml_module)) {
6838         push @extensions, "yml";
6839     } else {
6840         my @fallbacks;
6841         if ($CPAN::META->has_inst("Data::Dumper")) {
6842             push @extensions, "dd";
6843             push @fallbacks, "Data::Dumper";
6844         }
6845         if ($CPAN::META->has_inst("Storable")) {
6846             push @extensions, "st";
6847             push @fallbacks, "Storable";
6848         }
6849         if (@fallbacks) {
6850             local $" = " and ";
6851             unless ($self->{have_complained_about_missing_yaml}++) {
6852                 $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back ".
6853                                         "to @fallbacks to read prefs '$prefs_dir'\n");
6854             }
6855         } else {
6856             unless ($self->{have_complained_about_missing_yaml}++) {
6857                 $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot ".
6858                                         "read prefs '$prefs_dir'\n");
6859             }
6860         }
6861     }
6862     if (@extensions) {
6863         my $dh = DirHandle->new($prefs_dir)
6864             or die Carp::croak("Couldn't open '$prefs_dir': $!");
6865       DIRENT: for (sort $dh->read) {
6866             next if $_ eq "." || $_ eq "..";
6867             my $exte = join "|", @extensions;
6868             next unless /\.($exte)$/;
6869             my $thisexte = $1;
6870             my $abs = File::Spec->catfile($prefs_dir, $_);
6871             if (-f $abs) {
6872                 CPAN->debug(sprintf "abs[%s]", $abs) if $CPAN::DEBUG;
6873                 my @distropref;
6874                 if ($thisexte eq "yml") {
6875                     @distropref = @{CPAN->_yaml_loadfile($abs)};
6876                 } elsif ($thisexte eq "dd") {
6877                     package CPAN::Eval;
6878                     no strict;
6879                     open FH, "<$abs" or $CPAN::Frontend->mydie("Could not open '$abs': $!");
6880                     local $/;
6881                     my $eval = <FH>;
6882                     close FH;
6883                     eval $eval;
6884                     if ($@) {
6885                         $CPAN::Frontend->mydie("Error in distroprefs file $_\: $@");
6886                     }
6887                     my $i = 1;
6888                     while (${"VAR".$i}) {
6889                         push @distropref, ${"VAR".$i};
6890                         $i++;
6891                     }
6892                 } elsif ($thisexte eq "st") {
6893                     # eval because Storable is never forward compatible
6894                     eval { @distropref = @{scalar Storable::retrieve($abs)}; };
6895                     if ($@) {
6896                         $CPAN::Frontend->mywarn("Error reading distroprefs file ".
6897                                                 "$_, skipping\: $@");
6898                         $CPAN::Frontend->mysleep(4);
6899                         next DIRENT;
6900                     }
6901                 }
6902                 # $DB::single=1;
6903               ELEMENT: for my $y (0..$#distropref) {
6904                     my $distropref = $distropref[$y];
6905                     $self->_validate_distropref($distropref,$abs,$y);
6906                     my $match = $distropref->{match};
6907                     unless ($match) {
6908                         CPAN->debug("no 'match' in abs[$abs], skipping");
6909                         next ELEMENT;
6910                     }
6911                     my $ok = 1;
6912                     for my $sub_attribute (keys %$match) {
6913                         my $qr = eval "qr{$distropref->{match}{$sub_attribute}}";
6914                         if ($sub_attribute eq "module") {
6915                             my $okm = 0;
6916                             CPAN->debug(sprintf "abs[%s]distropref[%d]", $abs, scalar @distropref) if $CPAN::DEBUG;
6917                             my @modules = $self->containsmods;
6918                             CPAN->debug(sprintf "abs[%s]distropref[%d]modules[%s]", $abs, scalar @distropref, join(",",@modules)) if $CPAN::DEBUG;
6919                           MODULE: for my $module (@modules) {
6920                                 $okm ||= $module =~ /$qr/;
6921                                 last MODULE if $okm;
6922                             }
6923                             $ok &&= $okm;
6924                         } elsif ($sub_attribute eq "distribution") {
6925                             my $okd = $distroid =~ /$qr/;
6926                             $ok &&= $okd;
6927                         } elsif ($sub_attribute eq "perl") {
6928                             my $okp = $^X =~ /$qr/;
6929                             $ok &&= $okp;
6930                         } else {
6931                             $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ".
6932                                                    "unknown sub_attribut '$sub_attribute'. ".
6933                                                    "Please ".
6934                                                    "remove, cannot continue.");
6935                         }
6936                     }
6937                     CPAN->debug(sprintf "abs[%s]distropref[%d]ok[%d]", $abs, scalar @distropref, $ok) if $CPAN::DEBUG;
6938                     if ($ok) {
6939                         return {
6940                                 prefs => $distropref,
6941                                 prefs_file => $abs,
6942                                 prefs_file_doc => $y,
6943                                };
6944                     }
6945
6946                 }
6947             }
6948         }
6949     }
6950     return;
6951 }
6952
6953 # CPAN::Distribution::prefs
6954 sub prefs {
6955     my($self) = @_;
6956     if (exists $self->{prefs}) {
6957         return $self->{prefs}; # XXX comment out during debugging
6958     }
6959     if ($CPAN::Config->{prefs_dir}) {
6960         CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG;
6961         my $prefs = $self->_find_prefs();
6962         if ($prefs) {
6963             for my $x (qw(prefs prefs_file prefs_file_doc)) {
6964                 $self->{$x} = $prefs->{$x};
6965             }
6966             my $bs = sprintf(
6967                              "%s[%s]",
6968                              File::Basename::basename($self->{prefs_file}),
6969                              $self->{prefs_file_doc},
6970                             );
6971             my $filler1 = "_" x 22;
6972             my $filler2 = int(66 - length($bs))/2;
6973             $filler2 = 0 if $filler2 < 0;
6974             $filler2 = " " x $filler2;
6975             $CPAN::Frontend->myprint("
6976 $filler1 D i s t r o P r e f s $filler1
6977 $filler2 $bs $filler2
6978 ");
6979             $CPAN::Frontend->mysleep(1);
6980             return $self->{prefs};
6981         }
6982     }
6983     return +{};
6984 }
6985
6986 # CPAN::Distribution::make_x_arg
6987 sub make_x_arg {
6988     my($self, $whixh) = @_;
6989     my $make_x_arg;
6990     my $prefs = $self->prefs;
6991     if (
6992         $prefs
6993         && exists $prefs->{$whixh}
6994         && exists $prefs->{$whixh}{args}
6995         && $prefs->{$whixh}{args}
6996        ) {
6997         $make_x_arg = join(" ",
6998                            map {CPAN::HandleConfig
6999                                  ->safe_quote($_)} @{$prefs->{$whixh}{args}},
7000                           );
7001     }
7002     my $what = sprintf "make%s_arg", $whixh eq "make" ? "" : $whixh;
7003     $make_x_arg ||= $CPAN::Config->{$what};
7004     return $make_x_arg;
7005 }
7006
7007 # CPAN::Distribution::_make_command
7008 sub _make_command {
7009     my ($self) = @_;
7010     if ($self) {
7011         return
7012             CPAN::HandleConfig
7013                 ->safe_quote(
7014                              CPAN::HandleConfig->prefs_lookup($self,
7015                                                               q{make})
7016                              || $Config::Config{make}
7017                              || 'make'
7018                             );
7019     } else {
7020         # Old style call, without object. Deprecated
7021         Carp::confess("CPAN::_make_command() used as function. Don't Do That.");
7022         return
7023           safe_quote(undef,
7024                      CPAN::HandleConfig->prefs_lookup($self,q{make})
7025                      || $CPAN::Config->{make}
7026                      || $Config::Config{make}
7027                      || 'make');
7028     }
7029 }
7030
7031 #-> sub CPAN::Distribution::follow_prereqs ;
7032 sub follow_prereqs {
7033     my($self) = shift;
7034     my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
7035     return unless @prereq_tuples;
7036     my @prereq = map { $_->[0] } @prereq_tuples;
7037     my $pretty_id = $self->pretty_id;
7038     my %map = (
7039                b => "build_requires",
7040                r => "requires",
7041                c => "commandline",
7042               );
7043     my($filler1,$filler2,$filler3,$filler4);
7044     my $unsat = "Unsatisfied dependencies detected during";
7045     my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id);
7046     {
7047         my $r = int(($w - length($unsat))/2);
7048         my $l = $w - length($unsat) - $r;
7049         $filler1 = "-"x4 . " "x$l;
7050         $filler2 = " "x$r . "-"x4 . "\n";
7051     }
7052     {
7053         my $r = int(($w - length($pretty_id))/2);
7054         my $l = $w - length($pretty_id) - $r;
7055         $filler3 = "-"x4 . " "x$l;
7056         $filler4 = " "x$r . "-"x4 . "\n";
7057     }
7058     $CPAN::Frontend->
7059         myprint("$filler1 $unsat $filler2".
7060                 "$filler3 $pretty_id $filler4".
7061                 join("", map {"    $_->[0] \[$map{$_->[1]}]\n"} @prereq_tuples),
7062                );
7063     my $follow = 0;
7064     if ($CPAN::Config->{prerequisites_policy} eq "follow") {
7065         $follow = 1;
7066     } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
7067         my $answer = CPAN::Shell::colorable_makemaker_prompt(
7068 "Shall I follow them and prepend them to the queue
7069 of modules we are processing right now?", "yes");
7070         $follow = $answer =~ /^\s*y/i;
7071     } else {
7072         local($") = ", ";
7073         $CPAN::Frontend->
7074             myprint("  Ignoring dependencies on modules @prereq\n");
7075     }
7076     if ($follow) {
7077         my $id = $self->id;
7078         # color them as dirty
7079         for my $p (@prereq) {
7080             # warn "calling color_cmd_tmps(0,1)";
7081             my $any = CPAN::Shell->expandany($p);
7082             if ($any) {
7083                 $any->color_cmd_tmps(0,1);
7084             } else {
7085                 $CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$p'\n");
7086                 $CPAN::Frontend->mysleep(2);
7087             }
7088         }
7089         # queue them and re-queue yourself
7090         CPAN::Queue->jumpqueue([$id,$self->{reqtype}],
7091                                reverse @prereq_tuples);
7092         $self->{later} = "Delayed until after prerequisites";
7093         return 1; # signal success to the queuerunner
7094     }
7095 }
7096
7097 #-> sub CPAN::Distribution::unsat_prereq ;
7098 # return ([Foo=>1],[Bar=>1.2]) for normal modules
7099 # return ([perl=>5.008]) if we need a newer perl than we are running under
7100 sub unsat_prereq {
7101     my($self) = @_;
7102     my $prereq_pm = $self->prereq_pm or return;
7103     my(@need);
7104     my %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}});
7105   NEED: while (my($need_module, $need_version) = each %merged) {
7106         my($have_version,$inst_file);
7107         if ($need_module eq "perl") {
7108             $have_version = $];
7109             $inst_file = $^X;
7110         } else {
7111             my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
7112             next if $nmo->uptodate;
7113             $inst_file = $nmo->inst_file;
7114
7115             # if they have not specified a version, we accept any installed one
7116             if (not defined $need_version or
7117                 $need_version eq "0" or
7118                 $need_version eq "undef") {
7119                 next if defined $inst_file;
7120             }
7121
7122             $have_version = $nmo->inst_version;
7123         }
7124
7125         # We only want to install prereqs if either they're not installed
7126         # or if the installed version is too old. We cannot omit this
7127         # check, because if 'force' is in effect, nobody else will check.
7128         if (defined $inst_file) {
7129             my(@all_requirements) = split /\s*,\s*/, $need_version;
7130             local($^W) = 0;
7131             my $ok = 0;
7132           RQ: for my $rq (@all_requirements) {
7133                 if ($rq =~ s|>=\s*||) {
7134                 } elsif ($rq =~ s|>\s*||) {
7135                     # 2005-12: one user
7136                     if (CPAN::Version->vgt($have_version,$rq)){
7137                         $ok++;
7138                     }
7139                     next RQ;
7140                 } elsif ($rq =~ s|!=\s*||) {
7141                     # 2005-12: no user
7142                     if (CPAN::Version->vcmp($have_version,$rq)){
7143                         $ok++;
7144                         next RQ;
7145                     } else {
7146                         last RQ;
7147                     }
7148                 } elsif ($rq =~ m|<=?\s*|) {
7149                     # 2005-12: no user
7150                     $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n");
7151                     $ok++;
7152                     next RQ;
7153                 }
7154                 if (! CPAN::Version->vgt($rq, $have_version)){
7155                     $ok++;
7156                 }
7157                 CPAN->debug(sprintf("need_module[%s]inst_file[%s]".
7158                                     "inst_version[%s]rq[%s]ok[%d]",
7159                                     $need_module,
7160                                     $inst_file,
7161                                     $have_version,
7162                                     CPAN::Version->readable($rq),
7163                                     $ok,
7164                                    )) if $CPAN::DEBUG;
7165             }
7166             next NEED if $ok == @all_requirements;
7167         }
7168
7169         if ($need_module eq "perl") {
7170             return ["perl", $need_version];
7171         }
7172         if ($self->{sponsored_mods}{$need_module}++){
7173             # We have already sponsored it and for some reason it's still
7174             # not available. So we do nothing. Or what should we do?
7175             # if we push it again, we have a potential infinite loop
7176             next;
7177         }
7178         my $needed_as = exists $prereq_pm->{requires}{$need_module} ? "r" : "b";
7179         push @need, [$need_module,$needed_as];
7180     }
7181     @need;
7182 }
7183
7184 #-> sub CPAN::Distribution::read_yaml ;
7185 sub read_yaml {
7186     my($self) = @_;
7187     return $self->{yaml_content} if exists $self->{yaml_content};
7188     my $build_dir = $self->{build_dir};
7189     my $yaml = File::Spec->catfile($build_dir,"META.yml");
7190     $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
7191     return unless -f $yaml;
7192     eval { $self->{yaml_content} = CPAN->_yaml_loadfile($yaml)->[0]; };
7193     if ($@) {
7194         $CPAN::Frontend->mywarn("Warning (probably harmless): Could not read ".
7195                                 "'$yaml'. Falling back to other ".
7196                                 "methods to determine prerequisites\n");
7197         return; # if we die, then we cannot read YAML's own META.yml
7198     }
7199     if (not exists $self->{yaml_content}{dynamic_config}
7200         or $self->{yaml_content}{dynamic_config}
7201        ) {
7202         $self->{yaml_content} = undef;
7203     }
7204     $self->debug(sprintf "yaml_content[%s]", $self->{yaml_content} || "UNDEF")
7205         if $CPAN::DEBUG;
7206     return $self->{yaml_content};
7207 }
7208
7209 #-> sub CPAN::Distribution::prereq_pm ;
7210 sub prereq_pm {
7211     my($self) = @_;
7212     $self->{prereq_pm_detected} ||= 0;
7213     CPAN->debug("prereq_pm_detected[$self->{prereq_pm_detected}]") if $CPAN::DEBUG;
7214     return $self->{prereq_pm} if $self->{prereq_pm_detected};
7215     return unless $self->{writemakefile}  # no need to have succeeded
7216                                           # but we must have run it
7217         || $self->{modulebuild};
7218     CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
7219                 $self->{writemakefile}||"",
7220                 $self->{modulebuild}||"",
7221                ) if $CPAN::DEBUG;
7222     my($req,$breq);
7223     if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
7224         $req =  $yaml->{requires} || {};
7225         $breq =  $yaml->{build_requires} || {};
7226         undef $req unless ref $req eq "HASH" && %$req;
7227         if ($req) {
7228             if ($yaml->{generated_by} &&
7229                 $yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
7230                 my $eummv = do { local $^W = 0; $1+0; };
7231                 if ($eummv < 6.2501) {
7232                     # thanks to Slaven for digging that out: MM before
7233                     # that could be wrong because it could reflect a
7234                     # previous release
7235                     undef $req;
7236                 }
7237             }
7238             my $areq;
7239             my $do_replace;
7240             while (my($k,$v) = each %{$req||{}}) {
7241                 if ($v =~ /\d/) {
7242                     $areq->{$k} = $v;
7243                 } elsif ($k =~ /[A-Za-z]/ &&
7244                          $v =~ /[A-Za-z]/ &&
7245                          $CPAN::META->exists("Module",$v)
7246                         ) {
7247                     $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
7248                                             "requires hash: $k => $v; I'll take both ".
7249                                             "key and value as a module name\n");
7250                     $CPAN::Frontend->mysleep(1);
7251                     $areq->{$k} = 0;
7252                     $areq->{$v} = 0;
7253                     $do_replace++;
7254                 }
7255             }
7256             $req = $areq if $do_replace;
7257         }
7258     }
7259     unless ($req || $breq) {
7260         my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
7261         my $makefile = File::Spec->catfile($build_dir,"Makefile");
7262         my $fh;
7263         if (-f $makefile
7264             and
7265             $fh = FileHandle->new("<$makefile\0")) {
7266             CPAN->debug("Getting prereq from Makefile") if $CPAN::DEBUG;
7267             local($/) = "\n";
7268             while (<$fh>) {
7269                 last if /MakeMaker post_initialize section/;
7270                 my($p) = m{^[\#]
7271                            \s+PREREQ_PM\s+=>\s+(.+)
7272                        }x;
7273                 next unless $p;
7274                 # warn "Found prereq expr[$p]";
7275
7276                 #  Regexp modified by A.Speer to remember actual version of file
7277                 #  PREREQ_PM hash key wants, then add to
7278                 while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
7279                     # In case a prereq is mentioned twice, complain.
7280                     if ( defined $req->{$1} ) {
7281                         warn "Warning: PREREQ_PM mentions $1 more than once, ".
7282                             "last mention wins";
7283                     }
7284                     $req->{$1} = $2;
7285                 }
7286                 last;
7287             }
7288         }
7289     }
7290     unless ($req || $breq) {
7291         my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
7292         my $buildfile = File::Spec->catfile($build_dir,"Build");
7293         if (-f $buildfile) {
7294             CPAN->debug("Found '$buildfile'") if $CPAN::DEBUG;
7295             my $build_prereqs = File::Spec->catfile($build_dir,"_build","prereqs");
7296             if (-f $build_prereqs) {
7297                 CPAN->debug("Getting prerequisites from '$build_prereqs'") if $CPAN::DEBUG;
7298                 my $content = do { local *FH;
7299                                    open FH, $build_prereqs
7300                                        or $CPAN::Frontend->mydie("Could not open ".
7301                                                                  "'$build_prereqs': $!");
7302                                    local $/;
7303                                    <FH>;
7304                                };
7305                 my $bphash = eval $content;
7306                 if ($@) {
7307                 } else {
7308                     $req  = $bphash->{requires} || +{};
7309                     $breq = $bphash->{build_requires} || +{};
7310                 }
7311             }
7312         }
7313     }
7314     if (-f "Build.PL"
7315         && ! -f "Makefile.PL"
7316         && ! exists $req->{"Module::Build"}
7317         && ! $CPAN::META->has_inst("Module::Build")) {
7318         $CPAN::Frontend->mywarn("  Warning: CPAN.pm discovered Module::Build as ".
7319                                 "undeclared prerequisite.\n".
7320                                 "  Adding it now as such.\n"
7321                                );
7322         $CPAN::Frontend->mysleep(5);
7323         $req->{"Module::Build"} = 0;
7324         delete $self->{writemakefile};
7325     }
7326     if ($req || $breq) {
7327         $self->{prereq_pm_detected}++;
7328         return $self->{prereq_pm} = { requires => $req, build_requires => $breq };
7329     }
7330 }
7331
7332 #-> sub CPAN::Distribution::test ;
7333 sub test {
7334     my($self) = @_;
7335     if (my $goto = $self->prefs->{goto}) {
7336         return $self->goto($goto);
7337     }
7338     $self->make;
7339     if ($CPAN::Signal){
7340       delete $self->{force_update};
7341       return;
7342     }
7343     # warn "XDEBUG: checking for notest: $self->{notest} $self";
7344     if ($self->{notest}) {
7345         $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
7346         return 1;
7347     }
7348
7349     my $make = $self->{modulebuild} ? "Build" : "make";
7350
7351     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
7352                            ? $ENV{PERL5LIB}
7353                            : ($ENV{PERLLIB} || "");
7354
7355     $CPAN::META->set_perl5lib;
7356     local $ENV{MAKEFLAGS}; # protect us from outer make calls
7357
7358     $CPAN::Frontend->myprint("Running $make test\n");
7359     if (my @prereq = $self->unsat_prereq){
7360         unless ($prereq[0][0] eq "perl") {
7361             return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
7362         }
7363     }
7364   EXCUSE: {
7365         my @e;
7366         unless (exists $self->{make} or exists $self->{later}) {
7367             push @e,
7368                 "Make had some problems, won't test";
7369         }
7370
7371         exists $self->{make} and
7372             (
7373              UNIVERSAL::can($self->{make},"failed") ?
7374              $self->{make}->failed :
7375              $self->{make} =~ /^NO/
7376             ) and push @e, "Can't test without successful make";
7377
7378         $self->{badtestcnt} ||= 0;
7379         $self->{badtestcnt} > 0 and
7380             push @e, "Won't repeat unsuccessful test during this command";
7381
7382         exists $self->{later} and length($self->{later}) and
7383             push @e, $self->{later};
7384
7385         if (exists $self->{build_dir}) {
7386             if ($CPAN::META->{is_tested}{$self->{build_dir}}
7387                 &&
7388                 exists $self->{make_test}
7389                 &&
7390                 !(
7391                   UNIVERSAL::can($self->{make_test},"failed") ?
7392                   $self->{make_test}->failed :
7393                   $self->{make_test} =~ /^NO/
7394                  )
7395                ) {
7396                 push @e, "Already tested successfully";
7397             }
7398         } elsif (!@e) {
7399             push @e, "Has no own directory";
7400         }
7401
7402         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
7403     }
7404     chdir $self->{'build_dir'} or
7405         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
7406     $self->debug("Changed directory to $self->{'build_dir'}")
7407         if $CPAN::DEBUG;
7408
7409     if ($^O eq 'MacOS') {
7410         Mac::BuildTools::make_test($self);
7411         return;
7412     }
7413
7414     if ($self->{modulebuild}) {
7415         my $v = CPAN::Shell->expand("Module","Test::Harness")->inst_version;
7416         if (CPAN::Version->vlt($v,2.62)) {
7417             $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
7418   '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n});
7419             $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old");
7420             return;
7421         }
7422     }
7423
7424     my $system;
7425     if (my $commandline = $self->prefs->{test}{commandline}) {
7426         $system = $commandline;
7427         $ENV{PERL} = $^X;
7428     } elsif ($self->{modulebuild}) {
7429         $system = sprintf "%s test", $self->_build_command();
7430     } else {
7431         $system = join " ", $self->_make_command(), "test";
7432     }
7433     my($tests_ok);
7434     my %env;
7435     while (my($k,$v) = each %ENV) {
7436         next unless defined $v;
7437         $env{$k} = $v;
7438     }
7439     local %ENV = %env;
7440     if (my $env = $self->prefs->{test}{env}) {
7441         for my $e (keys %$env) {
7442             $ENV{$e} = $env->{$e};
7443         }
7444     }
7445     my $expect_model = $self->_prefs_with_expect("test");
7446     my $want_expect = 0;
7447     if ( $expect_model && @{$expect_model->{talk}} ) {
7448         my $can_expect = $CPAN::META->has_inst("Expect");
7449         if ($can_expect) {
7450             $want_expect = 1;
7451         } else {
7452             $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
7453                                     "testing without\n");
7454         }
7455     }
7456     my $test_report = CPAN::HandleConfig->prefs_lookup($self,
7457                                                        q{test_report});
7458     my $want_report;
7459     if ($test_report) {
7460         my $can_report = $CPAN::META->has_inst("CPAN::Reporter");
7461         if ($can_report) {
7462             $want_report = 1;
7463         } else {
7464             $CPAN::Frontend->mywarn("CPAN::Reporter not installed, falling back to ".
7465                                     "testing without\n");
7466         }
7467     }
7468     my $ready_to_report = $want_report;
7469     if ($ready_to_report
7470         && (
7471             substr($self->id,-1,1) eq "."
7472             ||
7473             $self->author->id eq "LOCAL"
7474            )
7475        ) {
7476         $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
7477                                 "for local directories\n");
7478         $ready_to_report = 0;
7479     }
7480     if ($ready_to_report
7481         &&
7482         $self->prefs->{patches}
7483         &&
7484         @{$self->prefs->{patches}}
7485         &&
7486         $self->{patched}
7487        ) {
7488         $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
7489                                 "when the source has been patched\n");
7490         $ready_to_report = 0;
7491     }
7492     if ($want_expect) {
7493         if ($ready_to_report) {
7494             $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ".
7495                                     "not supported when distroprefs specify ".
7496                                     "an interactive test\n");
7497         }
7498         $tests_ok = $self->_run_via_expect($system,$expect_model) == 0;
7499     } elsif ( $ready_to_report ) {
7500         $tests_ok = CPAN::Reporter::test($self, $system);
7501     } else {
7502         $tests_ok = system($system) == 0;
7503     }
7504     $self->introduce_myself;
7505     if ( $tests_ok ) {
7506         {
7507             my @prereq;
7508
7509             for my $m (keys %{$self->{sponsored_mods}}) {
7510                 my $m_obj = CPAN::Shell->expand("Module",$m);
7511                 # XXX we need available_version which reflects
7512                 # $ENV{PERL5LIB} so that already tested but not yet
7513                 # installed modules are counted.
7514                 my $available_version = $m_obj->available_version;
7515                 if ($available_version &&
7516                     !CPAN::Version->vlt($available_version,$self->{PREREQ_PM}{$m})
7517                    ) {
7518                     CPAN->debug("m[$m] good enough available_version[$available_version]")
7519                         if $CPAN::DEBUG;
7520                 } else {
7521                     push @prereq, $m;
7522                 }
7523             }
7524             if (@prereq){
7525                 my $cnt = @prereq;
7526                 my $which = join ",", @prereq;
7527                 my $but = $cnt == 1 ? "one dependency not OK ($which)" :
7528                     "$cnt dependencies missing ($which)";
7529                 $CPAN::Frontend->mywarn("Tests succeeded but $but\n");
7530                 $self->{make_test} = CPAN::Distrostatus->new("NO $but");
7531                 $self->store_persistent_state;
7532                 return;
7533             }
7534         }
7535
7536         $CPAN::Frontend->myprint("  $system -- OK\n");
7537         $CPAN::META->is_tested($self->{'build_dir'});
7538         $self->{make_test} = CPAN::Distrostatus->new("YES");
7539     } else {
7540         $self->{make_test} = CPAN::Distrostatus->new("NO");
7541         $self->{badtestcnt}++;
7542         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
7543     }
7544     $self->store_persistent_state;
7545 }
7546
7547 sub _prefs_with_expect {
7548     my($self,$where) = @_;
7549     return unless my $prefs = $self->prefs;
7550     return unless my $where_prefs = $prefs->{$where};
7551     if ($where_prefs->{expect}) {
7552         return {
7553                 mode => "deterministic",
7554                 timeout => 15,
7555                 talk => $where_prefs->{expect},
7556                };
7557     } elsif ($where_prefs->{"eexpect"}) {
7558         return $where_prefs->{"eexpect"};
7559     }
7560     return;
7561 }
7562
7563 #-> sub CPAN::Distribution::clean ;
7564 sub clean {
7565     my($self) = @_;
7566     my $make = $self->{modulebuild} ? "Build" : "make";
7567     $CPAN::Frontend->myprint("Running $make clean\n");
7568     unless (exists $self->{archived}) {
7569         $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped".
7570                                 "/untarred, nothing done\n");
7571         return 1;
7572     }
7573     unless (exists $self->{build_dir}) {
7574         $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
7575         return 1;
7576     }
7577   EXCUSE: {
7578         my @e;
7579         exists $self->{make_clean} and $self->{make_clean} eq "YES" and
7580             push @e, "make clean already called once";
7581         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
7582     }
7583     chdir $self->{'build_dir'} or
7584         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
7585     $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
7586
7587     if ($^O eq 'MacOS') {
7588         Mac::BuildTools::make_clean($self);
7589         return;
7590     }
7591
7592     my $system;
7593     if ($self->{modulebuild}) {
7594         unless (-f "Build") {
7595             my $cwd = CPAN::anycwd();
7596             $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
7597                                     " in cwd[$cwd]. Danger, Will Robinson!");
7598             $CPAN::Frontend->mysleep(5);
7599         }
7600         $system = sprintf "%s clean", $self->_build_command();
7601     } else {
7602         $system  = join " ", $self->_make_command(), "clean";
7603     }
7604     my $system_ok = system($system) == 0;
7605     $self->introduce_myself;
7606     if ( $system_ok ) {
7607       $CPAN::Frontend->myprint("  $system -- OK\n");
7608
7609       # $self->force;
7610
7611       # Jost Krieger pointed out that this "force" was wrong because
7612       # it has the effect that the next "install" on this distribution
7613       # will untar everything again. Instead we should bring the
7614       # object's state back to where it is after untarring.
7615
7616       for my $k (qw(
7617                     force_update
7618                     install
7619                     writemakefile
7620                     make
7621                     make_test
7622                    )) {
7623           delete $self->{$k};
7624       }
7625       $self->{make_clean} = CPAN::Distrostatus->new("YES");
7626
7627     } else {
7628       # Hmmm, what to do if make clean failed?
7629
7630       $self->{make_clean} = CPAN::Distrostatus->new("NO");
7631       $CPAN::Frontend->mywarn(qq{  $system -- NOT OK\n});
7632
7633       # 2006-02-27: seems silly to me to force a make now
7634       # $self->force("make"); # so that this directory won't be used again
7635
7636     }
7637     $self->store_persistent_state;
7638 }
7639
7640 #-> sub CPAN::Distribution::goto ;
7641 sub goto {
7642     my($self,$goto) = @_;
7643     $goto = $self->normalize($goto);
7644
7645     # inject into the queue
7646
7647     CPAN::Queue->delete($self->id);
7648     CPAN::Queue->jumpqueue([$goto,$self->{reqtype}]);
7649
7650     # and run where we left off
7651
7652     my($method) = (caller(1))[3];
7653     CPAN->instance("CPAN::Distribution",$goto)->$method;
7654
7655 }
7656
7657 #-> sub CPAN::Distribution::install ;
7658 sub install {
7659     my($self) = @_;
7660     if (my $goto = $self->prefs->{goto}) {
7661         return $self->goto($goto);
7662     }
7663     $self->test;
7664     if ($CPAN::Signal){
7665       delete $self->{force_update};
7666       return;
7667     }
7668     my $make = $self->{modulebuild} ? "Build" : "make";
7669     $CPAN::Frontend->myprint("Running $make install\n");
7670   EXCUSE: {
7671         my @e;
7672         unless (exists $self->{make} or exists $self->{later}) {
7673             push @e,
7674                 "Make had some problems, won't install";
7675         }
7676
7677         exists $self->{make} and
7678             (
7679              UNIVERSAL::can($self->{make},"failed") ?
7680              $self->{make}->failed :
7681              $self->{make} =~ /^NO/
7682             ) and
7683                 push @e, "Make had returned bad status, install seems impossible";
7684
7685         if (exists $self->{build_dir}) {
7686         } elsif (!@e) {
7687             push @e, "Has no own directory";
7688         }
7689
7690         if (exists $self->{make_test} and
7691             (
7692              UNIVERSAL::can($self->{make_test},"failed") ?
7693              $self->{make_test}->failed :
7694              $self->{make_test} =~ /^NO/
7695             )){
7696             if ($self->{force_update}) {
7697                 $self->{make_test}->text("FAILED but failure ignored because ".
7698                                          "'force' in effect");
7699             } else {
7700                 push @e, "make test had returned bad status, ".
7701                     "won't install without force"
7702             }
7703         }
7704         if (exists $self->{install}) {
7705             if (UNIVERSAL::can($self->{install},"text") ?
7706                 $self->{install}->text eq "YES" :
7707                 $self->{install} =~ /^YES/
7708                ) {
7709                 push @e, "Already done";
7710             } else {
7711                 # comment in Todo on 2006-02-11; maybe retry?
7712                 push @e, "Already tried without success";
7713             }
7714         }
7715
7716         exists $self->{later} and length($self->{later}) and
7717             push @e, $self->{later};
7718
7719         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
7720     }
7721     chdir $self->{'build_dir'} or
7722         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
7723     $self->debug("Changed directory to $self->{'build_dir'}")
7724         if $CPAN::DEBUG;
7725
7726     if ($^O eq 'MacOS') {
7727         Mac::BuildTools::make_install($self);
7728         return;
7729     }
7730
7731     my $system;
7732     if (my $commandline = $self->prefs->{install}{commandline}) {
7733         $system = $commandline;
7734         $ENV{PERL} = $^X;
7735     } elsif ($self->{modulebuild}) {
7736         my($mbuild_install_build_command) =
7737             exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
7738                 $CPAN::Config->{mbuild_install_build_command} ?
7739                     $CPAN::Config->{mbuild_install_build_command} :
7740                         $self->_build_command();
7741         $system = sprintf("%s install %s",
7742                           $mbuild_install_build_command,
7743                           $CPAN::Config->{mbuild_install_arg},
7744                          );
7745     } else {
7746         my($make_install_make_command) =
7747             CPAN::HandleConfig->prefs_lookup($self,
7748                                              q{make_install_make_command})
7749                   || $self->_make_command();
7750         $system = sprintf("%s install %s",
7751                           $make_install_make_command,
7752                           $CPAN::Config->{make_install_arg},
7753                          );
7754     }
7755
7756     my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 ";
7757     my $brip = CPAN::HandleConfig->prefs_lookup($self,
7758                                                 q{build_requires_install_policy});
7759     $brip ||="ask/yes";
7760     my $id = $self->id;
7761     my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command
7762     my $want_install = "yes";
7763     if ($reqtype eq "b") {
7764         if ($brip eq "no") {
7765             $want_install = "no";
7766         } elsif ($brip =~ m|^ask/(.+)|) {
7767             my $default = $1;
7768             $default = "yes" unless $default =~ /^(y|n)/i;
7769             $want_install =
7770                 CPAN::Shell::colorable_makemaker_prompt
7771                       ("$id is just needed temporarily during building or testing. ".
7772                        "Do you want to install it permanently? (Y/n)",
7773                        $default);
7774         }
7775     }
7776     unless ($want_install =~ /^y/i) {
7777         my $is_only = "is only 'build_requires'";
7778         $CPAN::Frontend->mywarn("Not installing because $is_only\n");
7779         $self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
7780         delete $self->{force_update};
7781         return;
7782     }
7783     my($pipe) = FileHandle->new("$system $stderr |");
7784     my($makeout) = "";
7785     while (<$pipe>){
7786         print $_; # intentionally NOT use Frontend->myprint because it
7787                   # looks irritating when we markup in color what we
7788                   # just pass through from an external program
7789         $makeout .= $_;
7790     }
7791     $pipe->close;
7792     my $close_ok = $? == 0;
7793     $self->introduce_myself;
7794     if ( $close_ok ) {
7795         $CPAN::Frontend->myprint("  $system -- OK\n");
7796         $CPAN::META->is_installed($self->{build_dir});
7797         return $self->{install} = CPAN::Distrostatus->new("YES");
7798     } else {
7799         $self->{install} = CPAN::Distrostatus->new("NO");
7800         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
7801         my $mimc =
7802             CPAN::HandleConfig->prefs_lookup($self,
7803                                              q{make_install_make_command});
7804         if (
7805             $makeout =~ /permission/s
7806             && $> > 0
7807             && (
7808                 ! $mimc
7809                 || $mimc eq (CPAN::HandleConfig->prefs_lookup($self,
7810                                                               q{make}))
7811                )
7812            ) {
7813             $CPAN::Frontend->myprint(
7814                                      qq{----\n}.
7815                                      qq{  You may have to su }.
7816                                      qq{to root to install the package\n}.
7817                                      qq{  (Or you may want to run something like\n}.
7818                                      qq{    o conf make_install_make_command 'sudo make'\n}.
7819                                      qq{  to raise your permissions.}
7820                                     );
7821         }
7822     }
7823     delete $self->{force_update};
7824     $self->store_persistent_state;
7825 }
7826
7827 sub introduce_myself {
7828     my($self) = @_;
7829     $CPAN::Frontend->myprint(sprintf("  %s\n",$self->pretty_id));
7830 }
7831
7832 #-> sub CPAN::Distribution::dir ;
7833 sub dir {
7834     shift->{'build_dir'};
7835 }
7836
7837 #-> sub CPAN::Distribution::perldoc ;
7838 sub perldoc {
7839     my($self) = @_;
7840
7841     my($dist) = $self->id;
7842     my $package = $self->called_for;
7843
7844     $self->_display_url( $CPAN::Defaultdocs . $package );
7845 }
7846
7847 #-> sub CPAN::Distribution::_check_binary ;
7848 sub _check_binary {
7849     my ($dist,$shell,$binary) = @_;
7850     my ($pid,$out);
7851
7852     $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
7853       if $CPAN::DEBUG;
7854
7855     if ($CPAN::META->has_inst("File::Which")) {
7856         return File::Which::which($binary);
7857     } else {
7858         local *README;
7859         $pid = open README, "which $binary|"
7860             or $CPAN::Frontend->mywarn(qq{Could not fork 'which $binary': $!\n});
7861         return unless $pid;
7862         while (<README>) {
7863             $out .= $_;
7864         }
7865         close README
7866             or $CPAN::Frontend->mywarn("Could not run 'which $binary': $!\n")
7867                 and return;
7868     }
7869
7870     $CPAN::Frontend->myprint(qq{   + $out \n})
7871       if $CPAN::DEBUG && $out;
7872
7873     return $out;
7874 }
7875
7876 #-> sub CPAN::Distribution::_display_url ;
7877 sub _display_url {
7878     my($self,$url) = @_;
7879     my($res,$saved_file,$pid,$out);
7880
7881     $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
7882       if $CPAN::DEBUG;
7883
7884     # should we define it in the config instead?
7885     my $html_converter = "html2text";
7886
7887     my $web_browser = $CPAN::Config->{'lynx'} || undef;
7888     my $web_browser_out = $web_browser
7889       ? CPAN::Distribution->_check_binary($self,$web_browser)
7890         : undef;
7891
7892     if ($web_browser_out) {
7893         # web browser found, run the action
7894         my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
7895         $CPAN::Frontend->myprint(qq{system[$browser $url]})
7896           if $CPAN::DEBUG;
7897         $CPAN::Frontend->myprint(qq{
7898 Displaying URL
7899   $url
7900 with browser $browser
7901 });
7902         $CPAN::Frontend->mysleep(1);
7903         system("$browser $url");
7904         if ($saved_file) { 1 while unlink($saved_file) }
7905     } else {
7906         # web browser not found, let's try text only
7907         my $html_converter_out =
7908           CPAN::Distribution->_check_binary($self,$html_converter);
7909         $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out);
7910
7911         if ($html_converter_out ) {
7912             # html2text found, run it
7913             $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
7914             $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n})
7915                 unless defined($saved_file);
7916
7917             local *README;
7918             $pid = open README, "$html_converter $saved_file |"
7919               or $CPAN::Frontend->mydie(qq{
7920 Could not fork '$html_converter $saved_file': $!});
7921             my($fh,$filename);
7922             if ($CPAN::META->has_inst("File::Temp")) {
7923                 $fh = File::Temp->new(
7924                                       template => 'cpan_htmlconvert_XXXX',
7925                                       suffix => '.txt',
7926                                       unlink => 0,
7927                                      );
7928                 $filename = $fh->filename;
7929             } else {
7930                 $filename = "cpan_htmlconvert_$$.txt";
7931                 $fh = FileHandle->new();
7932                 open $fh, ">$filename" or die;
7933             }
7934             while (<README>) {
7935                 $fh->print($_);
7936             }
7937             close README or
7938                 $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
7939             my $tmpin = $fh->filename;
7940             $CPAN::Frontend->myprint(sprintf(qq{
7941 Run '%s %s' and
7942 saved output to %s\n},
7943                                              $html_converter,
7944                                              $saved_file,
7945                                              $tmpin,
7946                                             )) if $CPAN::DEBUG;
7947             close $fh;
7948             local *FH;
7949             open FH, $tmpin
7950                 or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
7951             my $fh_pager = FileHandle->new;
7952             local($SIG{PIPE}) = "IGNORE";
7953             my $pager = $CPAN::Config->{'pager'} || "cat";
7954             $fh_pager->open("|$pager")
7955                 or $CPAN::Frontend->mydie(qq{
7956 Could not open pager '$pager': $!});
7957             $CPAN::Frontend->myprint(qq{
7958 Displaying URL
7959   $url
7960 with pager "$pager"
7961 });
7962             $CPAN::Frontend->mysleep(1);
7963             $fh_pager->print(<FH>);
7964             $fh_pager->close;
7965         } else {
7966             # coldn't find the web browser or html converter
7967             $CPAN::Frontend->myprint(qq{
7968 You need to install lynx or $html_converter to use this feature.});
7969         }
7970     }
7971 }
7972
7973 #-> sub CPAN::Distribution::_getsave_url ;
7974 sub _getsave_url {
7975     my($dist, $shell, $url) = @_;
7976
7977     $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
7978       if $CPAN::DEBUG;
7979
7980     my($fh,$filename);
7981     if ($CPAN::META->has_inst("File::Temp")) {
7982         $fh = File::Temp->new(
7983                               template => "cpan_getsave_url_XXXX",
7984                               suffix => ".html",
7985                               unlink => 0,
7986                              );
7987         $filename = $fh->filename;
7988     } else {
7989         $fh = FileHandle->new;
7990         $filename = "cpan_getsave_url_$$.html";
7991     }
7992     my $tmpin = $filename;
7993     if ($CPAN::META->has_usable('LWP')) {
7994         $CPAN::Frontend->myprint("Fetching with LWP:
7995   $url
7996 ");
7997         my $Ua;
7998         CPAN::LWP::UserAgent->config;
7999         eval { $Ua = CPAN::LWP::UserAgent->new; };
8000         if ($@) {
8001             $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
8002             return;
8003         } else {
8004             my($var);
8005             $Ua->proxy('http', $var)
8006                 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
8007             $Ua->no_proxy($var)
8008                 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
8009         }
8010
8011         my $req = HTTP::Request->new(GET => $url);
8012         $req->header('Accept' => 'text/html');
8013         my $res = $Ua->request($req);
8014         if ($res->is_success) {
8015             $CPAN::Frontend->myprint(" + request successful.\n")
8016                 if $CPAN::DEBUG;
8017             print $fh $res->content;
8018             close $fh;
8019             $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
8020                 if $CPAN::DEBUG;
8021             return $tmpin;
8022         } else {
8023             $CPAN::Frontend->myprint(sprintf(
8024                                              "LWP failed with code[%s], message[%s]\n",
8025                                              $res->code,
8026                                              $res->message,
8027                                             ));
8028             return;
8029         }
8030     } else {
8031         $CPAN::Frontend->mywarn("  LWP not available\n");
8032         return;
8033     }
8034 }
8035
8036 # sub CPAN::Distribution::_build_command
8037 sub _build_command {
8038     my($self) = @_;
8039     if ($^O eq "MSWin32") { # special code needed at least up to
8040                             # Module::Build 0.2611 and 0.2706; a fix
8041                             # in M:B has been promised 2006-01-30
8042         my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
8043         return "$perl ./Build";
8044     }
8045     return "./Build";
8046 }
8047
8048 package CPAN::Bundle;
8049 use strict;
8050
8051 sub look {
8052     my $self = shift;
8053     $CPAN::Frontend->myprint($self->as_string);
8054 }
8055
8056 sub undelay {
8057     my $self = shift;
8058     delete $self->{later};
8059     for my $c ( $self->contains ) {
8060         my $obj = CPAN::Shell->expandany($c) or next;
8061         $obj->undelay;
8062     }
8063 }
8064
8065 # mark as dirty/clean
8066 #-> sub CPAN::Bundle::color_cmd_tmps ;
8067 sub color_cmd_tmps {
8068     my($self) = shift;
8069     my($depth) = shift || 0;
8070     my($color) = shift || 0;
8071     my($ancestors) = shift || [];
8072     # a module needs to recurse to its cpan_file, a distribution needs
8073     # to recurse into its prereq_pms, a bundle needs to recurse into its modules
8074
8075     return if exists $self->{incommandcolor}
8076         && $self->{incommandcolor}==$color;
8077     if ($depth>=100){
8078         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
8079     }
8080     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
8081
8082     for my $c ( $self->contains ) {
8083         my $obj = CPAN::Shell->expandany($c) or next;
8084         CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
8085         $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
8086     }
8087     if ($color==0) {
8088         delete $self->{badtestcnt};
8089     }
8090     $self->{incommandcolor} = $color;
8091 }
8092
8093 #-> sub CPAN::Bundle::as_string ;
8094 sub as_string {
8095     my($self) = @_;
8096     $self->contains;
8097     # following line must be "=", not "||=" because we have a moving target
8098     $self->{INST_VERSION} = $self->inst_version;
8099     return $self->SUPER::as_string;
8100 }
8101
8102 #-> sub CPAN::Bundle::contains ;
8103 sub contains {
8104     my($self) = @_;
8105     my($inst_file) = $self->inst_file || "";
8106     my($id) = $self->id;
8107     $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
8108     if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) {
8109         undef $inst_file;
8110     }
8111     unless ($inst_file) {
8112         # Try to get at it in the cpan directory
8113         $self->debug("no inst_file") if $CPAN::DEBUG;
8114         my $cpan_file;
8115         $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
8116               $cpan_file = $self->cpan_file;
8117         if ($cpan_file eq "N/A") {
8118             $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
8119   Maybe stale symlink? Maybe removed during session? Giving up.\n");
8120         }
8121         my $dist = $CPAN::META->instance('CPAN::Distribution',
8122                                          $self->cpan_file);
8123         $dist->get;
8124         $self->debug("id[$dist->{ID}]") if $CPAN::DEBUG;
8125         my($todir) = $CPAN::Config->{'cpan_home'};
8126         my(@me,$from,$to,$me);
8127         @me = split /::/, $self->id;
8128         $me[-1] .= ".pm";
8129         $me = File::Spec->catfile(@me);
8130         $from = $self->find_bundle_file($dist->{'build_dir'},join('/',@me));
8131         $to = File::Spec->catfile($todir,$me);
8132         File::Path::mkpath(File::Basename::dirname($to));
8133         File::Copy::copy($from, $to)
8134               or Carp::confess("Couldn't copy $from to $to: $!");
8135         $inst_file = $to;
8136     }
8137     my @result;
8138     my $fh = FileHandle->new;
8139     local $/ = "\n";
8140     open($fh,$inst_file) or die "Could not open '$inst_file': $!";
8141     my $in_cont = 0;
8142     $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
8143     while (<$fh>) {
8144         $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
8145             m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
8146         next unless $in_cont;
8147         next if /^=/;
8148         s/\#.*//;
8149         next if /^\s+$/;
8150         chomp;
8151         push @result, (split " ", $_, 2)[0];
8152     }
8153     close $fh;
8154     delete $self->{STATUS};
8155     $self->{CONTAINS} = \@result;
8156     $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
8157     unless (@result) {
8158         $CPAN::Frontend->mywarn(qq{
8159 The bundle file "$inst_file" may be a broken
8160 bundlefile. It seems not to contain any bundle definition.
8161 Please check the file and if it is bogus, please delete it.
8162 Sorry for the inconvenience.
8163 });
8164     }
8165     @result;
8166 }
8167
8168 #-> sub CPAN::Bundle::find_bundle_file
8169 # $where is in local format, $what is in unix format
8170 sub find_bundle_file {
8171     my($self,$where,$what) = @_;
8172     $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
8173 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
8174 ###    my $bu = File::Spec->catfile($where,$what);
8175 ###    return $bu if -f $bu;
8176     my $manifest = File::Spec->catfile($where,"MANIFEST");
8177     unless (-f $manifest) {
8178         require ExtUtils::Manifest;
8179         my $cwd = CPAN::anycwd();
8180         $self->safe_chdir($where);
8181         ExtUtils::Manifest::mkmanifest();
8182         $self->safe_chdir($cwd);
8183     }
8184     my $fh = FileHandle->new($manifest)
8185         or Carp::croak("Couldn't open $manifest: $!");
8186     local($/) = "\n";
8187     my $bundle_filename = $what;
8188     $bundle_filename =~ s|Bundle.*/||;
8189     my $bundle_unixpath;
8190     while (<$fh>) {
8191         next if /^\s*\#/;
8192         my($file) = /(\S+)/;
8193         if ($file =~ m|\Q$what\E$|) {
8194             $bundle_unixpath = $file;
8195             # return File::Spec->catfile($where,$bundle_unixpath); # bad
8196             last;
8197         }
8198         # retry if she managed to have no Bundle directory
8199         $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
8200     }
8201     return File::Spec->catfile($where, split /\//, $bundle_unixpath)
8202         if $bundle_unixpath;
8203     Carp::croak("Couldn't find a Bundle file in $where");
8204 }
8205
8206 # needs to work quite differently from Module::inst_file because of
8207 # cpan_home/Bundle/ directory and the possibility that we have
8208 # shadowing effect. As it makes no sense to take the first in @INC for
8209 # Bundles, we parse them all for $VERSION and take the newest.
8210
8211 #-> sub CPAN::Bundle::inst_file ;
8212 sub inst_file {
8213     my($self) = @_;
8214     my($inst_file);
8215     my(@me);
8216     @me = split /::/, $self->id;
8217     $me[-1] .= ".pm";
8218     my($incdir,$bestv);
8219     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
8220         my $bfile = File::Spec->catfile($incdir, @me);
8221         CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
8222         next unless -f $bfile;
8223         my $foundv = MM->parse_version($bfile);
8224         if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
8225             $self->{INST_FILE} = $bfile;
8226             $self->{INST_VERSION} = $bestv = $foundv;
8227         }
8228     }
8229     $self->{INST_FILE};
8230 }
8231
8232 #-> sub CPAN::Bundle::inst_version ;
8233 sub inst_version {
8234     my($self) = @_;
8235     $self->inst_file; # finds INST_VERSION as side effect
8236     $self->{INST_VERSION};
8237 }
8238
8239 #-> sub CPAN::Bundle::rematein ;
8240 sub rematein {
8241     my($self,$meth) = @_;
8242     $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
8243     my($id) = $self->id;
8244     Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
8245         unless $self->inst_file || $self->cpan_file;
8246     my($s,%fail);
8247     for $s ($self->contains) {
8248         my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
8249             $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
8250         if ($type eq 'CPAN::Distribution') {
8251             $CPAN::Frontend->mywarn(qq{
8252 The Bundle }.$self->id.qq{ contains
8253 explicitly a file '$s'.
8254 Going to $meth that.
8255 });
8256             $CPAN::Frontend->mysleep(5);
8257         }
8258         # possibly noisy action:
8259         $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
8260         my $obj = $CPAN::META->instance($type,$s);
8261         $obj->{reqtype} = $self->{reqtype};
8262         $obj->$meth();
8263         if ($obj->isa('CPAN::Bundle')
8264             &&
8265             exists $obj->{install_failed}
8266             &&
8267             ref($obj->{install_failed}) eq "HASH"
8268            ) {
8269           for (keys %{$obj->{install_failed}}) {
8270             $self->{install_failed}{$_} = undef; # propagate faiure up
8271                                                  # to me in a
8272                                                  # recursive call
8273             $fail{$s} = 1; # the bundle itself may have succeeded but
8274                            # not all children
8275           }
8276         } else {
8277           my $success;
8278           $success = $obj->can("uptodate") ? $obj->uptodate : 0;
8279           $success ||= $obj->{install} && $obj->{install} eq "YES";
8280           if ($success) {
8281             delete $self->{install_failed}{$s};
8282           } else {
8283             $fail{$s} = 1;
8284           }
8285         }
8286     }
8287
8288     # recap with less noise
8289     if ( $meth eq "install" ) {
8290         if (%fail) {
8291             require Text::Wrap;
8292             my $raw = sprintf(qq{Bundle summary:
8293 The following items in bundle %s had installation problems:},
8294                               $self->id
8295                              );
8296             $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
8297             $CPAN::Frontend->myprint("\n");
8298             my $paragraph = "";
8299             my %reported;
8300             for $s ($self->contains) {
8301               if ($fail{$s}){
8302                 $paragraph .= "$s ";
8303                 $self->{install_failed}{$s} = undef;
8304                 $reported{$s} = undef;
8305               }
8306             }
8307             my $report_propagated;
8308             for $s (sort keys %{$self->{install_failed}}) {
8309               next if exists $reported{$s};
8310               $paragraph .= "and the following items had problems
8311 during recursive bundle calls: " unless $report_propagated++;
8312               $paragraph .= "$s ";
8313             }
8314             $CPAN::Frontend->myprint(Text::Wrap::fill("  ","  ",$paragraph));
8315             $CPAN::Frontend->myprint("\n");
8316         } else {
8317             $self->{install} = 'YES';
8318         }
8319     }
8320 }
8321
8322 # If a bundle contains another that contains an xs_file we have here,
8323 # we just don't bother I suppose
8324 #-> sub CPAN::Bundle::xs_file
8325 sub xs_file {
8326     return 0;
8327 }
8328
8329 #-> sub CPAN::Bundle::force ;
8330 sub force   { shift->rematein('force',@_); }
8331 #-> sub CPAN::Bundle::notest ;
8332 sub notest  { shift->rematein('notest',@_); }
8333 #-> sub CPAN::Bundle::get ;
8334 sub get     { shift->rematein('get',@_); }
8335 #-> sub CPAN::Bundle::make ;
8336 sub make    { shift->rematein('make',@_); }
8337 #-> sub CPAN::Bundle::test ;
8338 sub test    {
8339     my $self = shift;
8340     $self->{badtestcnt} ||= 0;
8341     $self->rematein('test',@_);
8342 }
8343 #-> sub CPAN::Bundle::install ;
8344 sub install {
8345   my $self = shift;
8346   $self->rematein('install',@_);
8347 }
8348 #-> sub CPAN::Bundle::clean ;
8349 sub clean   { shift->rematein('clean',@_); }
8350
8351 #-> sub CPAN::Bundle::uptodate ;
8352 sub uptodate {
8353     my($self) = @_;
8354     return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
8355     my $c;
8356     foreach $c ($self->contains) {
8357         my $obj = CPAN::Shell->expandany($c);
8358         return 0 unless $obj->uptodate;
8359     }
8360     return 1;
8361 }
8362
8363 #-> sub CPAN::Bundle::readme ;
8364 sub readme  {
8365     my($self) = @_;
8366     my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
8367 No File found for bundle } . $self->id . qq{\n}), return;
8368     $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
8369     $CPAN::META->instance('CPAN::Distribution',$file)->readme;
8370 }
8371
8372 package CPAN::Module;
8373 use strict;
8374
8375 # Accessors
8376 # sub CPAN::Module::userid
8377 sub userid {
8378     my $self = shift;
8379     my $ro = $self->ro;
8380     return unless $ro;
8381     return $ro->{userid} || $ro->{CPAN_USERID};
8382 }
8383 # sub CPAN::Module::description
8384 sub description {
8385     my $self = shift;
8386     my $ro = $self->ro or return "";
8387     $ro->{description}
8388 }
8389
8390 sub distribution {
8391     my($self) = @_;
8392     CPAN::Shell->expand("Distribution",$self->cpan_file);
8393 }
8394
8395 # sub CPAN::Module::undelay
8396 sub undelay {
8397     my $self = shift;
8398     delete $self->{later};
8399     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
8400         $dist->undelay;
8401     }
8402 }
8403
8404 # mark as dirty/clean
8405 #-> sub CPAN::Module::color_cmd_tmps ;
8406 sub color_cmd_tmps {
8407     my($self) = shift;
8408     my($depth) = shift || 0;
8409     my($color) = shift || 0;
8410     my($ancestors) = shift || [];
8411     # a module needs to recurse to its cpan_file
8412
8413     return if exists $self->{incommandcolor}
8414         && $self->{incommandcolor}==$color;
8415     return if $depth>=1 && $self->uptodate;
8416     if ($depth>=100){
8417         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
8418     }
8419     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
8420
8421     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
8422         $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
8423     }
8424     if ($color==0) {
8425         delete $self->{badtestcnt};
8426     }
8427     $self->{incommandcolor} = $color;
8428 }
8429
8430 #-> sub CPAN::Module::as_glimpse ;
8431 sub as_glimpse {
8432     my($self) = @_;
8433     my(@m);
8434     my $class = ref($self);
8435     $class =~ s/^CPAN:://;
8436     my $color_on = "";
8437     my $color_off = "";
8438     if (
8439         $CPAN::Shell::COLOR_REGISTERED
8440         &&
8441         $CPAN::META->has_inst("Term::ANSIColor")
8442         &&
8443         $self->description
8444        ) {
8445         $color_on = Term::ANSIColor::color("green");
8446         $color_off = Term::ANSIColor::color("reset");
8447     }
8448     my $uptodateness = " ";
8449     if ($class eq "Bundle") {
8450     } elsif ($self->uptodate) {
8451         $uptodateness = "=";
8452     } elsif ($self->inst_version) {
8453         $uptodateness = "<";
8454     }
8455     push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n",
8456                      $class,
8457                      $uptodateness,
8458                      $color_on,
8459                      $self->id,
8460                      $color_off,
8461                      ($self->distribution ?
8462                       $self->distribution->pretty_id :
8463                       $self->cpan_userid
8464                      ),
8465                     );
8466     join "", @m;
8467 }
8468
8469 #-> sub CPAN::Module::dslip_status
8470 sub dslip_status {
8471     my($self) = @_;
8472     my($stat);
8473     @{$stat->{D}}{qw,i c a b R M S,}     = qw,idea
8474                                               pre-alpha alpha beta released
8475                                               mature standard,;
8476     @{$stat->{S}}{qw,m d u n a,}         = qw,mailing-list
8477                                               developer comp.lang.perl.*
8478                                               none abandoned,;
8479     @{$stat->{L}}{qw,p c + o h,}         = qw,perl C C++ other hybrid,;
8480     @{$stat->{I}}{qw,f r O p h n,}       = qw,functions
8481                                               references+ties
8482                                               object-oriented pragma
8483                                               hybrid none,;
8484     @{$stat->{P}}{qw,p g l b a o d r n,} = qw,Standard-Perl
8485                                               GPL LGPL
8486                                               BSD Artistic
8487                                               open-source
8488                                               distribution_allowed
8489                                               restricted_distribution
8490                                               no_licence,;
8491     for my $x (qw(d s l i p)) {
8492         $stat->{$x}{' '} = 'unknown';
8493         $stat->{$x}{'?'} = 'unknown';
8494     }
8495     my $ro = $self->ro;
8496     return +{} unless $ro && $ro->{statd};
8497     return {
8498             D  => $ro->{statd},
8499             S  => $ro->{stats},
8500             L  => $ro->{statl},
8501             I  => $ro->{stati},
8502             P  => $ro->{statp},
8503             DV => $stat->{D}{$ro->{statd}},
8504             SV => $stat->{S}{$ro->{stats}},
8505             LV => $stat->{L}{$ro->{statl}},
8506             IV => $stat->{I}{$ro->{stati}},
8507             PV => $stat->{P}{$ro->{statp}},
8508            };
8509 }
8510
8511 #-> sub CPAN::Module::as_string ;
8512 sub as_string {
8513     my($self) = @_;
8514     my(@m);
8515     CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
8516     my $class = ref($self);
8517     $class =~ s/^CPAN:://;
8518     local($^W) = 0;
8519     push @m, $class, " id = $self->{ID}\n";
8520     my $sprintf = "    %-12s %s\n";
8521     push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
8522         if $self->description;
8523     my $sprintf2 = "    %-12s %s (%s)\n";
8524     my($userid);
8525     $userid = $self->userid;
8526     if ( $userid ){
8527         my $author;
8528         if ($author = CPAN::Shell->expand('Author',$userid)) {
8529           my $email = "";
8530           my $m; # old perls
8531           if ($m = $author->email) {
8532             $email = " <$m>";
8533           }
8534           push @m, sprintf(
8535                            $sprintf2,
8536                            'CPAN_USERID',
8537                            $userid,
8538                            $author->fullname . $email
8539                           );
8540         }
8541     }
8542     push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
8543         if $self->cpan_version;
8544     if (my $cpan_file = $self->cpan_file){
8545         push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
8546         if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
8547             my $upload_date = $dist->upload_date;
8548             if ($upload_date) {
8549                 push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
8550             }
8551         }
8552     }
8553     my $sprintf3 = "    %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n";
8554     my $dslip = $self->dslip_status;
8555     push @m, sprintf(
8556                      $sprintf3,
8557                      'DSLIP_STATUS',
8558                      @{$dslip}{qw(D S L I P DV SV LV IV PV)},
8559                     ) if $dslip->{D};
8560     my $local_file = $self->inst_file;
8561     unless ($self->{MANPAGE}) {
8562         my $manpage;
8563         if ($local_file) {
8564             $manpage = $self->manpage_headline($local_file);
8565         } else {
8566             # If we have already untarred it, we should look there
8567             my $dist = $CPAN::META->instance('CPAN::Distribution',
8568                                              $self->cpan_file);
8569             # warn "dist[$dist]";
8570             # mff=manifest file; mfh=manifest handle
8571             my($mff,$mfh);
8572             if (
8573                 $dist->{build_dir}
8574                 and
8575                 (-f  ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
8576                 and
8577                 $mfh = FileHandle->new($mff)
8578                ) {
8579                 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
8580                 my $lfre = $self->id; # local file RE
8581                 $lfre =~ s/::/./g;
8582                 $lfre .= "\\.pm\$";
8583                 my($lfl); # local file file
8584                 local $/ = "\n";
8585                 my(@mflines) = <$mfh>;
8586                 for (@mflines) {
8587                     s/^\s+//;
8588                     s/\s.*//s;
8589                 }
8590                 while (length($lfre)>5 and !$lfl) {
8591                     ($lfl) = grep /$lfre/, @mflines;
8592                     CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
8593                     $lfre =~ s/.+?\.//;
8594                 }
8595                 $lfl =~ s/\s.*//; # remove comments
8596                 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
8597                 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
8598                 # warn "lfl_abs[$lfl_abs]";
8599                 if (-f $lfl_abs) {
8600                     $manpage = $self->manpage_headline($lfl_abs);
8601                 }
8602             }
8603         }
8604         $self->{MANPAGE} = $manpage if $manpage;
8605     }
8606     my($item);
8607     for $item (qw/MANPAGE/) {
8608         push @m, sprintf($sprintf, $item, $self->{$item})
8609             if exists $self->{$item};
8610     }
8611     for $item (qw/CONTAINS/) {
8612         push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
8613             if exists $self->{$item} && @{$self->{$item}};
8614     }
8615     push @m, sprintf($sprintf, 'INST_FILE',
8616                      $local_file || "(not installed)");
8617     push @m, sprintf($sprintf, 'INST_VERSION',
8618                      $self->inst_version) if $local_file;
8619     join "", @m, "\n";
8620 }
8621
8622 sub manpage_headline {
8623   my($self,$local_file) = @_;
8624   my(@local_file) = $local_file;
8625   $local_file =~ s/\.pm(?!\n)\Z/.pod/;
8626   push @local_file, $local_file;
8627   my(@result,$locf);
8628   for $locf (@local_file) {
8629     next unless -f $locf;
8630     my $fh = FileHandle->new($locf)
8631         or $Carp::Frontend->mydie("Couldn't open $locf: $!");
8632     my $inpod = 0;
8633     local $/ = "\n";
8634     while (<$fh>) {
8635       $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
8636           m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
8637       next unless $inpod;
8638       next if /^=/;
8639       next if /^\s+$/;
8640       chomp;
8641       push @result, $_;
8642     }
8643     close $fh;
8644     last if @result;
8645   }
8646   for (@result) {
8647       s/^\s+//;
8648       s/\s+$//;
8649   }
8650   join " ", @result;
8651 }
8652
8653 #-> sub CPAN::Module::cpan_file ;
8654 # Note: also inherited by CPAN::Bundle
8655 sub cpan_file {
8656     my $self = shift;
8657     # CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
8658     unless ($self->ro) {
8659         CPAN::Index->reload;
8660     }
8661     my $ro = $self->ro;
8662     if ($ro && defined $ro->{CPAN_FILE}){
8663         return $ro->{CPAN_FILE};
8664     } else {
8665         my $userid = $self->userid;
8666         if ( $userid ) {
8667             if ($CPAN::META->exists("CPAN::Author",$userid)) {
8668                 my $author = $CPAN::META->instance("CPAN::Author",
8669                                                    $userid);
8670                 my $fullname = $author->fullname;
8671                 my $email = $author->email;
8672                 unless (defined $fullname && defined $email) {
8673                     return sprintf("Contact Author %s",
8674                                    $userid,
8675                                   );
8676                 }
8677                 return "Contact Author $fullname <$email>";
8678             } else {
8679                 return "Contact Author $userid (Email address not available)";
8680             }
8681         } else {
8682             return "N/A";
8683         }
8684     }
8685 }
8686
8687 #-> sub CPAN::Module::cpan_version ;
8688 sub cpan_version {
8689     my $self = shift;
8690
8691     my $ro = $self->ro;
8692     unless ($ro) {
8693         # Can happen with modules that are not on CPAN
8694         $ro = {};
8695     }
8696     $ro->{CPAN_VERSION} = 'undef'
8697         unless defined $ro->{CPAN_VERSION};
8698     $ro->{CPAN_VERSION};
8699 }
8700
8701 #-> sub CPAN::Module::force ;
8702 sub force {
8703     my($self) = @_;
8704     $self->{'force_update'}++;
8705 }
8706
8707 sub notest {
8708     my($self) = @_;
8709     # warn "XDEBUG: set notest for Module";
8710     $self->{'notest'}++;
8711 }
8712
8713 #-> sub CPAN::Module::rematein ;
8714 sub rematein {
8715     my($self,$meth) = @_;
8716     $CPAN::Frontend->myprint(sprintf("Running %s for module '%s'\n",
8717                                      $meth,
8718                                      $self->id));
8719     my $cpan_file = $self->cpan_file;
8720     if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
8721       $CPAN::Frontend->mywarn(sprintf qq{
8722   The module %s isn\'t available on CPAN.
8723
8724   Either the module has not yet been uploaded to CPAN, or it is
8725   temporary unavailable. Please contact the author to find out
8726   more about the status. Try 'i %s'.
8727 },
8728                               $self->id,
8729                               $self->id,
8730                              );
8731       return;
8732     }
8733     my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
8734     $pack->called_for($self->id);
8735     $pack->force($meth) if exists $self->{'force_update'};
8736     $pack->notest($meth) if exists $self->{'notest'};
8737
8738     $pack->{reqtype} ||= "";
8739     CPAN->debug("dist-reqtype[$pack->{reqtype}]".
8740                 "self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG;
8741         if ($pack->{reqtype}) {
8742             if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) {
8743                 $pack->{reqtype} = $self->{reqtype};
8744                 if (
8745                     exists $pack->{install}
8746                     &&
8747                     (
8748                      UNIVERSAL::can($pack->{install},"failed") ?
8749                      $pack->{install}->failed :
8750                      $pack->{install} =~ /^NO/
8751                     )
8752                    ) {
8753                     delete $pack->{install};
8754                     $CPAN::Frontend->mywarn
8755                         ("Promoting $pack->{ID} from 'build_requires' to 'requires'");
8756                 }
8757             }
8758         } else {
8759             $pack->{reqtype} = $self->{reqtype};
8760         }
8761
8762     eval {
8763         $pack->$meth();
8764     };
8765     my $err = $@;
8766     $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
8767     $pack->unnotest if $pack->can("unnotest") && exists $self->{'notest'};
8768     delete $self->{'force_update'};
8769     delete $self->{'notest'};
8770     if ($err) {
8771         die $err;
8772     }
8773 }
8774
8775 #-> sub CPAN::Module::perldoc ;
8776 sub perldoc { shift->rematein('perldoc') }
8777 #-> sub CPAN::Module::readme ;
8778 sub readme  { shift->rematein('readme') }
8779 #-> sub CPAN::Module::look ;
8780 sub look    { shift->rematein('look') }
8781 #-> sub CPAN::Module::cvs_import ;
8782 sub cvs_import { shift->rematein('cvs_import') }
8783 #-> sub CPAN::Module::get ;
8784 sub get     { shift->rematein('get',@_) }
8785 #-> sub CPAN::Module::make ;
8786 sub make    { shift->rematein('make') }
8787 #-> sub CPAN::Module::test ;
8788 sub test   {
8789     my $self = shift;
8790     $self->{badtestcnt} ||= 0;
8791     $self->rematein('test',@_);
8792 }
8793 #-> sub CPAN::Module::uptodate ;
8794 sub uptodate {
8795     my($self) = @_;
8796     local($_); # protect against a bug in MakeMaker 6.17
8797     my($latest) = $self->cpan_version;
8798     $latest ||= 0;
8799     my($inst_file) = $self->inst_file;
8800     my($have) = 0;
8801     if (defined $inst_file) {
8802         $have = $self->inst_version;
8803     }
8804     local($^W)=0;
8805     if ($inst_file
8806         &&
8807         ! CPAN::Version->vgt($latest, $have)
8808        ) {
8809         CPAN->debug("returning uptodate. inst_file[$inst_file] ".
8810                     "latest[$latest] have[$have]") if $CPAN::DEBUG;
8811         return 1;
8812     }
8813     return;
8814 }
8815 #-> sub CPAN::Module::install ;
8816 sub install {
8817     my($self) = @_;
8818     my($doit) = 0;
8819     if ($self->uptodate
8820         &&
8821         not exists $self->{'force_update'}
8822        ) {
8823         $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
8824                                          $self->id,
8825                                          $self->inst_version,
8826                                         ));
8827     } else {
8828         $doit = 1;
8829     }
8830     my $ro = $self->ro;
8831     if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
8832         $CPAN::Frontend->mywarn(qq{
8833 \n\n\n     ***WARNING***
8834      The module $self->{ID} has no active maintainer.\n\n\n
8835 });
8836         $CPAN::Frontend->mysleep(5);
8837     }
8838     $self->rematein('install') if $doit;
8839 }
8840 #-> sub CPAN::Module::clean ;
8841 sub clean  { shift->rematein('clean') }
8842
8843 #-> sub CPAN::Module::inst_file ;
8844 sub inst_file {
8845     my($self) = @_;
8846     $self->_file_in_path([@INC]);
8847 }
8848
8849 #-> sub CPAN::Module::available_file ;
8850 sub available_file {
8851     my($self) = @_;
8852     my $sep = $Config::Config{path_sep};
8853     my $perllib = $ENV{PERL5LIB};
8854     $perllib = $ENV{PERLLIB} unless defined $perllib;
8855     my @perllib = split(/$sep/,$perllib) if defined $perllib;
8856     $self->_file_in_path([@perllib,@INC]);
8857 }
8858
8859 #-> sub CPAN::Module::file_in_path ;
8860 sub _file_in_path {
8861     my($self,$path) = @_;
8862     my($dir,@packpath);
8863     @packpath = split /::/, $self->{ID};
8864     $packpath[-1] .= ".pm";
8865     if (@packpath == 1 && $packpath[0] eq "readline.pm") {
8866         unshift @packpath, "Term", "ReadLine"; # historical reasons
8867     }
8868     foreach $dir (@$path) {
8869         my $pmfile = File::Spec->catfile($dir,@packpath);
8870         if (-f $pmfile){
8871             return $pmfile;
8872         }
8873     }
8874     return;
8875 }
8876
8877 #-> sub CPAN::Module::xs_file ;
8878 sub xs_file {
8879     my($self) = @_;
8880     my($dir,@packpath);
8881     @packpath = split /::/, $self->{ID};
8882     push @packpath, $packpath[-1];
8883     $packpath[-1] .= "." . $Config::Config{'dlext'};
8884     foreach $dir (@INC) {
8885         my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
8886         if (-f $xsfile){
8887             return $xsfile;
8888         }
8889     }
8890     return;
8891 }
8892
8893 #-> sub CPAN::Module::inst_version ;
8894 sub inst_version {
8895     my($self) = @_;
8896     my $parsefile = $self->inst_file or return;
8897     my $have = $self->parse_version($parsefile);
8898     $have;
8899 }
8900
8901 #-> sub CPAN::Module::inst_version ;
8902 sub available_version {
8903     my($self) = @_;
8904     my $parsefile = $self->available_file or return;
8905     my $have = $self->parse_version($parsefile);
8906     $have;
8907 }
8908
8909 #-> sub CPAN::Module::parse_version ;
8910 sub parse_version {
8911     my($self,$parsefile) = @_;
8912     my $have = MM->parse_version($parsefile);
8913     $have = "undef" unless defined $have && length $have;
8914     $have =~ s/^ //; # since the %vd hack these two lines here are needed
8915     $have =~ s/ $//; # trailing whitespace happens all the time
8916
8917     $have = CPAN::Version->readable($have);
8918
8919     $have =~ s/\s*//g; # stringify to float around floating point issues
8920     $have; # no stringify needed, \s* above matches always
8921 }
8922
8923 package CPAN;
8924 use strict;
8925
8926 1;
8927
8928
8929 __END__
8930
8931 =head1 NAME
8932
8933 CPAN - query, download and build perl modules from CPAN sites
8934
8935 =head1 SYNOPSIS
8936
8937 Interactive mode:
8938
8939   perl -MCPAN -e shell;
8940
8941 Batch mode:
8942
8943   use CPAN;
8944
8945   # Modules:
8946
8947   cpan> install Acme::Meta                       # in the shell
8948
8949   CPAN::Shell->install("Acme::Meta");            # in perl
8950
8951   # Distributions:
8952
8953   cpan> install NWCLARK/Acme-Meta-0.02.tar.gz    # in the shell
8954
8955   CPAN::Shell->
8956     install("NWCLARK/Acme-Meta-0.02.tar.gz");    # in perl
8957
8958   # module objects:
8959
8960   $mo = CPAN::Shell->expandany($mod);
8961   $mo = CPAN::Shell->expand("Module",$mod);      # same thing
8962
8963   # distribution objects:
8964
8965   $do = CPAN::Shell->expand("Module",$mod)->distribution;
8966   $do = CPAN::Shell->expandany($distro);         # same thing
8967   $do = CPAN::Shell->expand("Distribution",
8968                             $distro);            # same thing
8969
8970 =head1 STATUS
8971
8972 This module and its competitor, the CPANPLUS module, are both much
8973 cooler than the other.
8974
8975 =head1 COMPATIBILITY
8976
8977 CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted
8978 newer versions. It is getting more and more difficult to get the
8979 minimal prerequisites working on older perls. It is close to
8980 impossible to get the whole Bundle::CPAN working there. If you're in
8981 the position to have only these old versions, be advised that CPAN is
8982 designed to work fine without the Bundle::CPAN installed.
8983
8984 To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is
8985 compatible with ancient perls and that File::Temp is listed as a
8986 prerequisite but CPAN has reasonable workarounds if it is missing.
8987
8988 =head1 DESCRIPTION
8989
8990 The CPAN module is designed to automate the make and install of perl
8991 modules and extensions. It includes some primitive searching
8992 capabilities and knows how to use Net::FTP or LWP (or some external
8993 download clients) to fetch the raw data from the net.
8994
8995 Modules are fetched from one or more of the mirrored CPAN
8996 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
8997 directory.
8998
8999 The CPAN module also supports the concept of named and versioned
9000 I<bundles> of modules. Bundles simplify the handling of sets of
9001 related modules. See Bundles below.
9002
9003 The package contains a session manager and a cache manager. There is
9004 no status retained between sessions. The session manager keeps track
9005 of what has been fetched, built and installed in the current
9006 session. The cache manager keeps track of the disk space occupied by
9007 the make processes and deletes excess space according to a simple FIFO
9008 mechanism.
9009
9010 All methods provided are accessible in a programmer style and in an
9011 interactive shell style.
9012
9013 =head2 CPAN::shell([$prompt, $command]) Starting Interactive Mode
9014
9015 The interactive mode is entered by running
9016
9017     perl -MCPAN -e shell
9018
9019 which puts you into a readline interface. You will have the most fun if
9020 you install Term::ReadKey and Term::ReadLine to enjoy both history and
9021 command completion.
9022
9023 Once you are on the command line, type 'h' and the rest should be
9024 self-explanatory.
9025
9026 The function call C<shell> takes two optional arguments, one is the
9027 prompt, the second is the default initial command line (the latter
9028 only works if a real ReadLine interface module is installed).
9029
9030 The most common uses of the interactive modes are
9031
9032 =over 2
9033
9034 =item Searching for authors, bundles, distribution files and modules
9035
9036 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
9037 for each of the four categories and another, C<i> for any of the
9038 mentioned four. Each of the four entities is implemented as a class
9039 with slightly differing methods for displaying an object.
9040
9041 Arguments you pass to these commands are either strings exactly matching
9042 the identification string of an object or regular expressions that are
9043 then matched case-insensitively against various attributes of the
9044 objects. The parser recognizes a regular expression only if you
9045 enclose it between two slashes.
9046
9047 The principle is that the number of found objects influences how an
9048 item is displayed. If the search finds one item, the result is
9049 displayed with the rather verbose method C<as_string>, but if we find
9050 more than one, we display each object with the terse method
9051 C<as_glimpse>.
9052
9053 =item make, test, install, clean  modules or distributions
9054
9055 These commands take any number of arguments and investigate what is
9056 necessary to perform the action. If the argument is a distribution
9057 file name (recognized by embedded slashes), it is processed. If it is
9058 a module, CPAN determines the distribution file in which this module
9059 is included and processes that, following any dependencies named in
9060 the module's META.yml or Makefile.PL (this behavior is controlled by
9061 the configuration parameter C<prerequisites_policy>.)
9062
9063 Any C<make> or C<test> are run unconditionally. An
9064
9065   install <distribution_file>
9066
9067 also is run unconditionally. But for
9068
9069   install <module>
9070
9071 CPAN checks if an install is actually needed for it and prints
9072 I<module up to date> in the case that the distribution file containing
9073 the module doesn't need to be updated.
9074
9075 CPAN also keeps track of what it has done within the current session
9076 and doesn't try to build a package a second time regardless if it
9077 succeeded or not. The C<force> pragma may precede another command
9078 (currently: C<make>, C<test>, or C<install>) and executes the
9079 command from scratch and tries to continue in case of some errors.
9080
9081 Example:
9082
9083     cpan> install OpenGL
9084     OpenGL is up to date.
9085     cpan> force install OpenGL
9086     Running make
9087     OpenGL-0.4/
9088     OpenGL-0.4/COPYRIGHT
9089     [...]
9090
9091 The C<notest> pragma may be set to skip the test part in the build
9092 process.
9093
9094 Example:
9095
9096     cpan> notest install Tk
9097
9098 A C<clean> command results in a
9099
9100   make clean
9101
9102 being executed within the distribution file's working directory.
9103
9104 =item get, readme, perldoc, look module or distribution
9105
9106 C<get> downloads a distribution file without further action. C<readme>
9107 displays the README file of the associated distribution. C<Look> gets
9108 and untars (if not yet done) the distribution file, changes to the
9109 appropriate directory and opens a subshell process in that directory.
9110 C<perldoc> displays the pod documentation of the module in html or
9111 plain text format.
9112
9113 =item ls author
9114
9115 =item ls globbing_expression
9116
9117 The first form lists all distribution files in and below an author's
9118 CPAN directory as they are stored in the CHECKUMS files distributed on
9119 CPAN. The listing goes recursive into all subdirectories.
9120
9121 The second form allows to limit or expand the output with shell
9122 globbing as in the following examples:
9123
9124           ls JV/make*
9125           ls GSAR/*make*
9126           ls */*make*
9127
9128 The last example is very slow and outputs extra progress indicators
9129 that break the alignment of the result.
9130
9131 Note that globbing only lists directories explicitly asked for, for
9132 example FOO/* will not list FOO/bar/Acme-Sthg-n.nn.tar.gz. This may be
9133 regarded as a bug and may be changed in future versions.
9134
9135 =item failed
9136
9137 The C<failed> command reports all distributions that failed on one of
9138 C<make>, C<test> or C<install> for some reason in the currently
9139 running shell session.
9140
9141 =item Lockfile
9142
9143 Interactive sessions maintain a lockfile, per default C<~/.cpan/.lock>.
9144 Batch jobs can run without a lockfile and do not disturb each other.
9145
9146 The shell offers to run in I<degraded mode> when another process is
9147 holding the lockfile. This is an experimental feature that is not yet
9148 tested very well. This second shell then does not write the history
9149 file, does not use the metadata file and has a different prompt.
9150
9151 =item Signals
9152
9153 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
9154 in the cpan-shell it is intended that you can press C<^C> anytime and
9155 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
9156 to clean up and leave the shell loop. You can emulate the effect of a
9157 SIGTERM by sending two consecutive SIGINTs, which usually means by
9158 pressing C<^C> twice.
9159
9160 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
9161 SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl
9162 Build.PL> subprocess.
9163
9164 =back
9165
9166 =head2 CPAN::Shell
9167
9168 The commands that are available in the shell interface are methods in
9169 the package CPAN::Shell. If you enter the shell command, all your
9170 input is split by the Text::ParseWords::shellwords() routine which
9171 acts like most shells do. The first word is being interpreted as the
9172 method to be called and the rest of the words are treated as arguments
9173 to this method. Continuation lines are supported if a line ends with a
9174 literal backslash.
9175
9176 =head2 autobundle
9177
9178 C<autobundle> writes a bundle file into the
9179 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
9180 a list of all modules that are both available from CPAN and currently
9181 installed within @INC. The name of the bundle file is based on the
9182 current date and a counter.
9183
9184 =head2 hosts
9185
9186 This commands provides a statistical overview over recent download
9187 activities. The data for this is collected in the YAML file
9188 C<FTPstats.yml> in your C<cpan_home> directory. If no YAML module is
9189 configured or YAML not installed, then no stats are provided.
9190
9191 =head2 mkmyconfig
9192
9193 mkmyconfig() writes your own CPAN::MyConfig file into your ~/.cpan/
9194 directory so that you can save your own preferences instead of the
9195 system wide ones.
9196
9197 =head2 recompile
9198
9199 recompile() is a very special command in that it takes no argument and
9200 runs the make/test/install cycle with brute force over all installed
9201 dynamically loadable extensions (aka XS modules) with 'force' in
9202 effect. The primary purpose of this command is to finish a network
9203 installation. Imagine, you have a common source tree for two different
9204 architectures. You decide to do a completely independent fresh
9205 installation. You start on one architecture with the help of a Bundle
9206 file produced earlier. CPAN installs the whole Bundle for you, but
9207 when you try to repeat the job on the second architecture, CPAN
9208 responds with a C<"Foo up to date"> message for all modules. So you
9209 invoke CPAN's recompile on the second architecture and you're done.
9210
9211 Another popular use for C<recompile> is to act as a rescue in case your
9212 perl breaks binary compatibility. If one of the modules that CPAN uses
9213 is in turn depending on binary compatibility (so you cannot run CPAN
9214 commands), then you should try the CPAN::Nox module for recovery.
9215
9216 =head2 report Bundle|Distribution|Module
9217
9218 The C<report> command temporarily turns on the C<test_report> config
9219 variable, then runs the C<force test> command with the given
9220 arguments. The C<force> pragma is used to re-run the tests and repeat
9221 every step that might have failed before.
9222
9223 =head2 upgrade [Module|/Regex/]...
9224
9225 The C<upgrade> command first runs an C<r> command with the given
9226 arguments and then installs the newest versions of all modules that
9227 were listed by that.
9228
9229 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
9230
9231 Although it may be considered internal, the class hierarchy does matter
9232 for both users and programmer. CPAN.pm deals with above mentioned four
9233 classes, and all those classes share a set of methods. A classical
9234 single polymorphism is in effect. A metaclass object registers all
9235 objects of all kinds and indexes them with a string. The strings
9236 referencing objects have a separated namespace (well, not completely
9237 separated):
9238
9239          Namespace                         Class
9240
9241    words containing a "/" (slash)      Distribution
9242     words starting with Bundle::          Bundle
9243           everything else            Module or Author
9244
9245 Modules know their associated Distribution objects. They always refer
9246 to the most recent official release. Developers may mark their releases
9247 as unstable development versions (by inserting an underbar into the
9248 module version number which will also be reflected in the distribution
9249 name when you run 'make dist'), so the really hottest and newest
9250 distribution is not always the default.  If a module Foo circulates
9251 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
9252 way to install version 1.23 by saying
9253
9254     install Foo
9255
9256 This would install the complete distribution file (say
9257 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
9258 like to install version 1.23_90, you need to know where the
9259 distribution file resides on CPAN relative to the authors/id/
9260 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
9261 so you would have to say
9262
9263     install BAR/Foo-1.23_90.tar.gz
9264
9265 The first example will be driven by an object of the class
9266 CPAN::Module, the second by an object of class CPAN::Distribution.
9267
9268 =head2 Integrating local directories
9269
9270 Distribution objects are normally distributions from the CPAN, but
9271 there is a slightly degenerate case for Distribution objects, too,
9272 normally only needed by developers. If a distribution object ends with
9273 a dot or is a dot by itself, then it represents a local directory and
9274 all actions such as C<make>, C<test>, and C<install> are applied
9275 directly to that directory. This gives the command C<cpan .> an
9276 interesting touch: while the normal mantra of installing a CPAN module
9277 without CPAN.pm is one of
9278
9279     perl Makefile.PL                 perl Build.PL
9280            ( go and get prerequisites )
9281     make                             ./Build
9282     make test                        ./Build test
9283     make install                     ./Build install
9284
9285 the command C<cpan .> does all of this at once. It figures out which
9286 of the two mantras is appropriate, fetches and installs all
9287 prerequisites, cares for them recursively and finally finishes the
9288 installation of the module in the current directory, be it a CPAN
9289 module or not.
9290
9291 =head1 PROGRAMMER'S INTERFACE
9292
9293 If you do not enter the shell, the available shell commands are both
9294 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
9295 functions in the calling package (C<install(...)>).  Before calling low-level
9296 commands it makes sense to initialize components of CPAN you need, e.g.:
9297
9298   CPAN::HandleConfig->load;
9299   CPAN::Shell::setup_output;
9300   CPAN::Index->reload;
9301
9302 High-level commands do such initializations automatically.
9303
9304 There's currently only one class that has a stable interface -
9305 CPAN::Shell. All commands that are available in the CPAN shell are
9306 methods of the class CPAN::Shell. Each of the commands that produce
9307 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
9308 the IDs of all modules within the list.
9309
9310 =over 2
9311
9312 =item expand($type,@things)
9313
9314 The IDs of all objects available within a program are strings that can
9315 be expanded to the corresponding real objects with the
9316 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
9317 list of CPAN::Module objects according to the C<@things> arguments
9318 given. In scalar context it only returns the first element of the
9319 list.
9320
9321 =item expandany(@things)
9322
9323 Like expand, but returns objects of the appropriate type, i.e.
9324 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
9325 CPAN::Distribution objects for distributions. Note: it does not expand
9326 to CPAN::Author objects.
9327
9328 =item Programming Examples
9329
9330 This enables the programmer to do operations that combine
9331 functionalities that are available in the shell.
9332
9333     # install everything that is outdated on my disk:
9334     perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
9335
9336     # install my favorite programs if necessary:
9337     for $mod (qw(Net::FTP Digest::SHA Data::Dumper)){
9338         CPAN::Shell->install($mod);
9339     }
9340
9341     # list all modules on my disk that have no VERSION number
9342     for $mod (CPAN::Shell->expand("Module","/./")){
9343         next unless $mod->inst_file;
9344         # MakeMaker convention for undefined $VERSION:
9345         next unless $mod->inst_version eq "undef";
9346         print "No VERSION in ", $mod->id, "\n";
9347     }
9348
9349     # find out which distribution on CPAN contains a module:
9350     print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
9351
9352 Or if you want to write a cronjob to watch The CPAN, you could list
9353 all modules that need updating. First a quick and dirty way:
9354
9355     perl -e 'use CPAN; CPAN::Shell->r;'
9356
9357 If you don't want to get any output in the case that all modules are
9358 up to date, you can parse the output of above command for the regular
9359 expression //modules are up to date// and decide to mail the output
9360 only if it doesn't match. Ick?
9361
9362 If you prefer to do it more in a programmer style in one single
9363 process, maybe something like this suits you better:
9364
9365   # list all modules on my disk that have newer versions on CPAN
9366   for $mod (CPAN::Shell->expand("Module","/./")){
9367     next unless $mod->inst_file;
9368     next if $mod->uptodate;
9369     printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
9370         $mod->id, $mod->inst_version, $mod->cpan_version;
9371   }
9372
9373 If that gives you too much output every day, you maybe only want to
9374 watch for three modules. You can write
9375
9376   for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
9377
9378 as the first line instead. Or you can combine some of the above
9379 tricks:
9380
9381   # watch only for a new mod_perl module
9382   $mod = CPAN::Shell->expand("Module","mod_perl");
9383   exit if $mod->uptodate;
9384   # new mod_perl arrived, let me know all update recommendations
9385   CPAN::Shell->r;
9386
9387 =back
9388
9389 =head2 Methods in the other Classes
9390
9391 =over 4
9392
9393 =item CPAN::Author::as_glimpse()
9394
9395 Returns a one-line description of the author
9396
9397 =item CPAN::Author::as_string()
9398
9399 Returns a multi-line description of the author
9400
9401 =item CPAN::Author::email()
9402
9403 Returns the author's email address
9404
9405 =item CPAN::Author::fullname()
9406
9407 Returns the author's name
9408
9409 =item CPAN::Author::name()
9410
9411 An alias for fullname
9412
9413 =item CPAN::Bundle::as_glimpse()
9414
9415 Returns a one-line description of the bundle
9416
9417 =item CPAN::Bundle::as_string()
9418
9419 Returns a multi-line description of the bundle
9420
9421 =item CPAN::Bundle::clean()
9422
9423 Recursively runs the C<clean> method on all items contained in the bundle.
9424
9425 =item CPAN::Bundle::contains()
9426
9427 Returns a list of objects' IDs contained in a bundle. The associated
9428 objects may be bundles, modules or distributions.
9429
9430 =item CPAN::Bundle::force($method,@args)
9431
9432 Forces CPAN to perform a task that it normally would have refused to
9433 do. Force takes as arguments a method name to be called and any number
9434 of additional arguments that should be passed to the called method.
9435 The internals of the object get the needed changes so that CPAN.pm
9436 does not refuse to take the action. The C<force> is passed recursively
9437 to all contained objects.
9438
9439 =item CPAN::Bundle::get()
9440
9441 Recursively runs the C<get> method on all items contained in the bundle
9442
9443 =item CPAN::Bundle::inst_file()
9444
9445 Returns the highest installed version of the bundle in either @INC or
9446 C<$CPAN::Config->{cpan_home}>. Note that this is different from
9447 CPAN::Module::inst_file.
9448
9449 =item CPAN::Bundle::inst_version()
9450
9451 Like CPAN::Bundle::inst_file, but returns the $VERSION
9452
9453 =item CPAN::Bundle::uptodate()
9454
9455 Returns 1 if the bundle itself and all its members are uptodate.
9456
9457 =item CPAN::Bundle::install()
9458
9459 Recursively runs the C<install> method on all items contained in the bundle
9460
9461 =item CPAN::Bundle::make()
9462
9463 Recursively runs the C<make> method on all items contained in the bundle
9464
9465 =item CPAN::Bundle::readme()
9466
9467 Recursively runs the C<readme> method on all items contained in the bundle
9468
9469 =item CPAN::Bundle::test()
9470
9471 Recursively runs the C<test> method on all items contained in the bundle
9472
9473 =item CPAN::Distribution::as_glimpse()
9474
9475 Returns a one-line description of the distribution
9476
9477 =item CPAN::Distribution::as_string()
9478
9479 Returns a multi-line description of the distribution
9480
9481 =item CPAN::Distribution::author
9482
9483 Returns the CPAN::Author object of the maintainer who uploaded this
9484 distribution
9485
9486 =item CPAN::Distribution::clean()
9487
9488 Changes to the directory where the distribution has been unpacked and
9489 runs C<make clean> there.
9490
9491 =item CPAN::Distribution::containsmods()
9492
9493 Returns a list of IDs of modules contained in a distribution file.
9494 Only works for distributions listed in the 02packages.details.txt.gz
9495 file. This typically means that only the most recent version of a
9496 distribution is covered.
9497
9498 =item CPAN::Distribution::cvs_import()
9499
9500 Changes to the directory where the distribution has been unpacked and
9501 runs something like
9502
9503     cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
9504
9505 there.
9506
9507 =item CPAN::Distribution::dir()
9508
9509 Returns the directory into which this distribution has been unpacked.
9510
9511 =item CPAN::Distribution::force($method,@args)
9512
9513 Forces CPAN to perform a task that normally would have failed. Force
9514 takes as arguments a method name to be called and any number of
9515 additional arguments that should be passed to the called method. The
9516 internals of the object get the needed changes so that CPAN.pm does
9517 not refuse to take the action.
9518
9519 =item CPAN::Distribution::get()
9520
9521 Downloads the distribution from CPAN and unpacks it. Does nothing if
9522 the distribution has already been downloaded and unpacked within the
9523 current session.
9524
9525 =item CPAN::Distribution::install()
9526
9527 Changes to the directory where the distribution has been unpacked and
9528 runs the external command C<make install> there. If C<make> has not
9529 yet been run, it will be run first. A C<make test> will be issued in
9530 any case and if this fails, the install will be canceled. The
9531 cancellation can be avoided by letting C<force> run the C<install> for
9532 you.
9533
9534 This install method has only the power to install the distribution if
9535 there are no dependencies in the way. To install an object and all of
9536 its dependencies, use CPAN::Shell->install.
9537
9538 Note that install() gives no meaningful return value. See uptodate().
9539
9540 =item CPAN::Distribution::isa_perl()
9541
9542 Returns 1 if this distribution file seems to be a perl distribution.
9543 Normally this is derived from the file name only, but the index from
9544 CPAN can contain a hint to achieve a return value of true for other
9545 filenames too.
9546
9547 =item CPAN::Distribution::look()
9548
9549 Changes to the directory where the distribution has been unpacked and
9550 opens a subshell there. Exiting the subshell returns.
9551
9552 =item CPAN::Distribution::make()
9553
9554 First runs the C<get> method to make sure the distribution is
9555 downloaded and unpacked. Changes to the directory where the
9556 distribution has been unpacked and runs the external commands C<perl
9557 Makefile.PL> or C<perl Build.PL> and C<make> there.
9558
9559 =item CPAN::Distribution::perldoc()
9560
9561 Downloads the pod documentation of the file associated with a
9562 distribution (in html format) and runs it through the external
9563 command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
9564 isn't available, it converts it to plain text with external
9565 command html2text and runs it through the pager specified
9566 in C<$CPAN::Config->{pager}>
9567
9568 =item CPAN::Distribution::prefs()
9569
9570 Returns the hash reference from the first matching YAML file that the
9571 user has deposited in the C<prefs_dir/> directory. The first
9572 succeeding match wins. The files in the C<prefs_dir/> are processed
9573 alphabetically and the canonical distroname (e.g.
9574 AUTHOR/Foo-Bar-3.14.tar.gz) is matched against the regular expressions
9575 stored in the $root->{match}{distribution} attribute value.
9576 Additionally all module names contained in a distribution are matched
9577 agains the regular expressions in the $root->{match}{module} attribute
9578 value. The two match values are ANDed together. Each of the two
9579 attributes are optional.
9580
9581 =item CPAN::Distribution::prereq_pm()
9582
9583 Returns the hash reference that has been announced by a distribution
9584 as the merge of the C<requires> element and the C<build_requires>
9585 element of the META.yml or the C<PREREQ_PM> hash in the
9586 C<Makefile.PL>. Note: works only after an attempt has been made to
9587 C<make> the distribution. Returns undef otherwise.
9588
9589 =item CPAN::Distribution::readme()
9590
9591 Downloads the README file associated with a distribution and runs it
9592 through the pager specified in C<$CPAN::Config->{pager}>.
9593
9594 =item CPAN::Distribution::read_yaml()
9595
9596 Returns the content of the META.yml of this distro as a hashref. Note:
9597 works only after an attempt has been made to C<make> the distribution.
9598 Returns undef otherwise. Also returns undef if the content of META.yml
9599 is dynamic.
9600
9601 =item CPAN::Distribution::test()
9602
9603 Changes to the directory where the distribution has been unpacked and
9604 runs C<make test> there.
9605
9606 =item CPAN::Distribution::uptodate()
9607
9608 Returns 1 if all the modules contained in the distribution are
9609 uptodate. Relies on containsmods.
9610
9611 =item CPAN::Index::force_reload()
9612
9613 Forces a reload of all indices.
9614
9615 =item CPAN::Index::reload()
9616
9617 Reloads all indices if they have not been read for more than
9618 C<$CPAN::Config->{index_expire}> days.
9619
9620 =item CPAN::InfoObj::dump()
9621
9622 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
9623 inherit this method. It prints the data structure associated with an
9624 object. Useful for debugging. Note: the data structure is considered
9625 internal and thus subject to change without notice.
9626
9627 =item CPAN::Module::as_glimpse()
9628
9629 Returns a one-line description of the module in four columns: The
9630 first column contains the word C<Module>, the second column consists
9631 of one character: an equals sign if this module is already installed
9632 and uptodate, a less-than sign if this module is installed but can be
9633 upgraded, and a space if the module is not installed. The third column
9634 is the name of the module and the fourth column gives maintainer or
9635 distribution information.
9636
9637 =item CPAN::Module::as_string()
9638
9639 Returns a multi-line description of the module
9640
9641 =item CPAN::Module::clean()
9642
9643 Runs a clean on the distribution associated with this module.
9644
9645 =item CPAN::Module::cpan_file()
9646
9647 Returns the filename on CPAN that is associated with the module.
9648
9649 =item CPAN::Module::cpan_version()
9650
9651 Returns the latest version of this module available on CPAN.
9652
9653 =item CPAN::Module::cvs_import()
9654
9655 Runs a cvs_import on the distribution associated with this module.
9656
9657 =item CPAN::Module::description()
9658
9659 Returns a 44 character description of this module. Only available for
9660 modules listed in The Module List (CPAN/modules/00modlist.long.html
9661 or 00modlist.long.txt.gz)
9662
9663 =item CPAN::Module::distribution()
9664
9665 Returns the CPAN::Distribution object that contains the current
9666 version of this module.
9667
9668 =item CPAN::Module::dslip_status()
9669
9670 Returns a hash reference. The keys of the hash are the letters C<D>,
9671 C<S>, C<L>, C<I>, and <P>, for development status, support level,
9672 language, interface and public licence respectively. The data for the
9673 DSLIP status are collected by pause.perl.org when authors register
9674 their namespaces. The values of the 5 hash elements are one-character
9675 words whose meaning is described in the table below. There are also 5
9676 hash elements C<DV>, C<SV>, C<LV>, C<IV>, and <PV> that carry a more
9677 verbose value of the 5 status variables.
9678
9679 Where the 'DSLIP' characters have the following meanings:
9680
9681   D - Development Stage  (Note: *NO IMPLIED TIMESCALES*):
9682     i   - Idea, listed to gain consensus or as a placeholder
9683     c   - under construction but pre-alpha (not yet released)
9684     a/b - Alpha/Beta testing
9685     R   - Released
9686     M   - Mature (no rigorous definition)
9687     S   - Standard, supplied with Perl 5
9688
9689   S - Support Level:
9690     m   - Mailing-list
9691     d   - Developer
9692     u   - Usenet newsgroup comp.lang.perl.modules
9693     n   - None known, try comp.lang.perl.modules
9694     a   - abandoned; volunteers welcome to take over maintainance
9695
9696   L - Language Used:
9697     p   - Perl-only, no compiler needed, should be platform independent
9698     c   - C and perl, a C compiler will be needed
9699     h   - Hybrid, written in perl with optional C code, no compiler needed
9700     +   - C++ and perl, a C++ compiler will be needed
9701     o   - perl and another language other than C or C++
9702
9703   I - Interface Style
9704     f   - plain Functions, no references used
9705     h   - hybrid, object and function interfaces available
9706     n   - no interface at all (huh?)
9707     r   - some use of unblessed References or ties
9708     O   - Object oriented using blessed references and/or inheritance
9709
9710   P - Public License
9711     p   - Standard-Perl: user may choose between GPL and Artistic
9712     g   - GPL: GNU General Public License
9713     l   - LGPL: "GNU Lesser General Public License" (previously known as
9714           "GNU Library General Public License")
9715     b   - BSD: The BSD License
9716     a   - Artistic license alone
9717     o   - open source: appoved by www.opensource.org
9718     d   - allows distribution without restrictions
9719     r   - restricted distribtion
9720     n   - no license at all
9721
9722 =item CPAN::Module::force($method,@args)
9723
9724 Forces CPAN to perform a task that normally would have failed. Force
9725 takes as arguments a method name to be called and any number of
9726 additional arguments that should be passed to the called method. The
9727 internals of the object get the needed changes so that CPAN.pm does
9728 not refuse to take the action.
9729
9730 =item CPAN::Module::get()
9731
9732 Runs a get on the distribution associated with this module.
9733
9734 =item CPAN::Module::inst_file()
9735
9736 Returns the filename of the module found in @INC. The first file found
9737 is reported just like perl itself stops searching @INC when it finds a
9738 module.
9739
9740 =item CPAN::Module::available_file()
9741
9742 Returns the filename of the module found in PERL5LIB or @INC. The
9743 first file found is reported. The advantage of this method over
9744 C<inst_file> is that modules that have been tested but not yet
9745 installed are included because PERL5LIB keeps track of tested modules.
9746
9747 =item CPAN::Module::inst_version()
9748
9749 Returns the version number of the installed module in readable format.
9750
9751 =item CPAN::Module::available_version()
9752
9753 Returns the version number of the available module in readable format.
9754
9755 =item CPAN::Module::install()
9756
9757 Runs an C<install> on the distribution associated with this module.
9758
9759 =item CPAN::Module::look()
9760
9761 Changes to the directory where the distribution associated with this
9762 module has been unpacked and opens a subshell there. Exiting the
9763 subshell returns.
9764
9765 =item CPAN::Module::make()
9766
9767 Runs a C<make> on the distribution associated with this module.
9768
9769 =item CPAN::Module::manpage_headline()
9770
9771 If module is installed, peeks into the module's manpage, reads the
9772 headline and returns it. Moreover, if the module has been downloaded
9773 within this session, does the equivalent on the downloaded module even
9774 if it is not installed.
9775
9776 =item CPAN::Module::perldoc()
9777
9778 Runs a C<perldoc> on this module.
9779
9780 =item CPAN::Module::readme()
9781
9782 Runs a C<readme> on the distribution associated with this module.
9783
9784 =item CPAN::Module::test()
9785
9786 Runs a C<test> on the distribution associated with this module.
9787
9788 =item CPAN::Module::uptodate()
9789
9790 Returns 1 if the module is installed and up-to-date.
9791
9792 =item CPAN::Module::userid()
9793
9794 Returns the author's ID of the module.
9795
9796 =back
9797
9798 =head2 Cache Manager
9799
9800 Currently the cache manager only keeps track of the build directory
9801 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
9802 deletes complete directories below C<build_dir> as soon as the size of
9803 all directories there gets bigger than $CPAN::Config->{build_cache}
9804 (in MB). The contents of this cache may be used for later
9805 re-installations that you intend to do manually, but will never be
9806 trusted by CPAN itself. This is due to the fact that the user might
9807 use these directories for building modules on different architectures.
9808
9809 There is another directory ($CPAN::Config->{keep_source_where}) where
9810 the original distribution files are kept. This directory is not
9811 covered by the cache manager and must be controlled by the user. If
9812 you choose to have the same directory as build_dir and as
9813 keep_source_where directory, then your sources will be deleted with
9814 the same fifo mechanism.
9815
9816 =head2 Bundles
9817
9818 A bundle is just a perl module in the namespace Bundle:: that does not
9819 define any functions or methods. It usually only contains documentation.
9820
9821 It starts like a perl module with a package declaration and a $VERSION
9822 variable. After that the pod section looks like any other pod with the
9823 only difference being that I<one special pod section> exists starting with
9824 (verbatim):
9825
9826         =head1 CONTENTS
9827
9828 In this pod section each line obeys the format
9829
9830         Module_Name [Version_String] [- optional text]
9831
9832 The only required part is the first field, the name of a module
9833 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
9834 of the line is optional. The comment part is delimited by a dash just
9835 as in the man page header.
9836
9837 The distribution of a bundle should follow the same convention as
9838 other distributions.
9839
9840 Bundles are treated specially in the CPAN package. If you say 'install
9841 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
9842 the modules in the CONTENTS section of the pod. You can install your
9843 own Bundles locally by placing a conformant Bundle file somewhere into
9844 your @INC path. The autobundle() command which is available in the
9845 shell interface does that for you by including all currently installed
9846 modules in a snapshot bundle file.
9847
9848 =head1 PREREQUISITES
9849
9850 If you have a local mirror of CPAN and can access all files with
9851 "file:" URLs, then you only need a perl better than perl5.003 to run
9852 this module. Otherwise Net::FTP is strongly recommended. LWP may be
9853 required for non-UNIX systems or if your nearest CPAN site is
9854 associated with a URL that is not C<ftp:>.
9855
9856 If you have neither Net::FTP nor LWP, there is a fallback mechanism
9857 implemented for an external ftp command or for an external lynx
9858 command.
9859
9860 =head1 UTILITIES
9861
9862 =head2 Finding packages and VERSION
9863
9864 This module presumes that all packages on CPAN
9865
9866 =over 2
9867
9868 =item *
9869
9870 declare their $VERSION variable in an easy to parse manner. This
9871 prerequisite can hardly be relaxed because it consumes far too much
9872 memory to load all packages into the running program just to determine
9873 the $VERSION variable. Currently all programs that are dealing with
9874 version use something like this
9875
9876     perl -MExtUtils::MakeMaker -le \
9877         'print MM->parse_version(shift)' filename
9878
9879 If you are author of a package and wonder if your $VERSION can be
9880 parsed, please try the above method.
9881
9882 =item *
9883
9884 come as compressed or gzipped tarfiles or as zip files and contain a
9885 C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
9886 without much enthusiasm).
9887
9888 =back
9889
9890 =head2 Debugging
9891
9892 The debugging of this module is a bit complex, because we have
9893 interferences of the software producing the indices on CPAN, of the
9894 mirroring process on CPAN, of packaging, of configuration, of
9895 synchronicity, and of bugs within CPAN.pm.
9896
9897 For debugging the code of CPAN.pm itself in interactive mode some more
9898 or less useful debugging aid can be turned on for most packages within
9899 CPAN.pm with one of
9900
9901 =over 2
9902
9903 =item o debug package...
9904
9905 sets debug mode for packages.
9906
9907 =item o debug -package...
9908
9909 unsets debug mode for packages.
9910
9911 =item o debug all
9912
9913 turns debugging on for all packages.
9914
9915 =item o debug number
9916
9917 =back
9918
9919 which sets the debugging packages directly. Note that C<o debug 0>
9920 turns debugging off.
9921
9922 What seems quite a successful strategy is the combination of C<reload
9923 cpan> and the debugging switches. Add a new debug statement while
9924 running in the shell and then issue a C<reload cpan> and see the new
9925 debugging messages immediately without losing the current context.
9926
9927 C<o debug> without an argument lists the valid package names and the
9928 current set of packages in debugging mode. C<o debug> has built-in
9929 completion support.
9930
9931 For debugging of CPAN data there is the C<dump> command which takes
9932 the same arguments as make/test/install and outputs each object's
9933 Data::Dumper dump. If an argument looks like a perl variable and
9934 contains one of C<$>, C<@> or C<%>, it is eval()ed and fed to
9935 Data::Dumper directly.
9936
9937 =head2 Floppy, Zip, Offline Mode
9938
9939 CPAN.pm works nicely without network too. If you maintain machines
9940 that are not networked at all, you should consider working with file:
9941 URLs. Of course, you have to collect your modules somewhere first. So
9942 you might use CPAN.pm to put together all you need on a networked
9943 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
9944 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
9945 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
9946 with this floppy. See also below the paragraph about CD-ROM support.
9947
9948 =head2 Basic Utilities for Programmers
9949
9950 =over 2
9951
9952 =item has_inst($module)
9953
9954 Returns true if the module is installed. See the source for details.
9955
9956 =item has_usable($module)
9957
9958 Returns true if the module is installed and several and is in a usable
9959 state. Only useful for a handful of modules that are used internally.
9960 See the source for details.
9961
9962 =item instance($module)
9963
9964 The constructor for all the singletons used to represent modules,
9965 distributions, authors and bundles. If the object already exists, this
9966 method returns the object, otherwise it calls the constructor.
9967
9968 =back
9969
9970 =head1 CONFIGURATION
9971
9972 When the CPAN module is used for the first time, a configuration
9973 dialog tries to determine a couple of site specific options. The
9974 result of the dialog is stored in a hash reference C< $CPAN::Config >
9975 in a file CPAN/Config.pm.
9976
9977 The default values defined in the CPAN/Config.pm file can be
9978 overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
9979 best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
9980 added to the search path of the CPAN module before the use() or
9981 require() statements. The mkmyconfig command writes this file for you.
9982
9983 The C<o conf> command has various bells and whistles:
9984
9985 =over
9986
9987 =item completion support
9988
9989 If you have a ReadLine module installed, you can hit TAB at any point
9990 of the commandline and C<o conf> will offer you completion for the
9991 built-in subcommands and/or config variable names.
9992
9993 =item displaying some help: o conf help
9994
9995 Displays a short help
9996
9997 =item displaying current values: o conf [KEY]
9998
9999 Displays the current value(s) for this config variable. Without KEY
10000 displays all subcommands and config variables.
10001
10002 Example:
10003
10004   o conf shell
10005
10006 =item changing of scalar values: o conf KEY VALUE
10007
10008 Sets the config variable KEY to VALUE. The empty string can be
10009 specified as usual in shells, with C<''> or C<"">
10010
10011 Example:
10012
10013   o conf wget /usr/bin/wget
10014
10015 =item changing of list values: o conf KEY SHIFT|UNSHIFT|PUSH|POP|SPLICE|LIST
10016
10017 If a config variable name ends with C<list>, it is a list. C<o conf
10018 KEY shift> removes the first element of the list, C<o conf KEY pop>
10019 removes the last element of the list. C<o conf KEYS unshift LIST>
10020 prepends a list of values to the list, C<o conf KEYS push LIST>
10021 appends a list of valued to the list.
10022
10023 Likewise, C<o conf KEY splice LIST> passes the LIST to the according
10024 splice command.
10025
10026 Finally, any other list of arguments is taken as a new list value for
10027 the KEY variable discarding the previous value.
10028
10029 Examples:
10030
10031   o conf urllist unshift http://cpan.dev.local/CPAN
10032   o conf urllist splice 3 1
10033   o conf urllist http://cpan1.local http://cpan2.local ftp://ftp.perl.org
10034
10035 =item interactive editing: o conf init [MATCH|LIST]
10036
10037 Runs an interactive configuration dialog for matching variables.
10038 Without argument runs the dialog over all supported config variables.
10039 To specify a MATCH the argument must be enclosed by slashes.
10040
10041 Examples:
10042
10043   o conf init ftp_passive ftp_proxy
10044   o conf init /color/
10045
10046 =item reverting to saved: o conf defaults
10047
10048 Reverts all config variables to the state in the saved config file.
10049
10050 =item saving the config: o conf commit
10051
10052 Saves all config variables to the current config file (CPAN/Config.pm
10053 or CPAN/MyConfig.pm that was loaded at start).
10054
10055 =back
10056
10057 The configuration dialog can be started any time later again by
10058 issuing the command C< o conf init > in the CPAN shell. A subset of
10059 the configuration dialog can be run by issuing C<o conf init WORD>
10060 where WORD is any valid config variable or a regular expression.
10061
10062 =head2 Config Variables
10063
10064 Currently the following keys in the hash reference $CPAN::Config are
10065 defined:
10066
10067   build_cache        size of cache for directories to build modules
10068   build_dir          locally accessible directory to build modules
10069   build_dir_reuse    boolean if distros in build_dir are persistent
10070   build_requires_install_policy
10071                      to install or not to install: when a module is
10072                      only needed for building. yes|no|ask/yes|ask/no
10073   bzip2              path to external prg
10074   cache_metadata     use serializer to cache metadata
10075   commands_quote     prefered character to use for quoting external
10076                      commands when running them. Defaults to double
10077                      quote on Windows, single tick everywhere else;
10078                      can be set to space to disable quoting
10079   check_sigs         if signatures should be verified
10080   colorize_output    boolean if Term::ANSIColor should colorize output
10081   colorize_print     Term::ANSIColor attributes for normal output
10082   colorize_warn      Term::ANSIColor attributes for warnings
10083   commandnumber_in_prompt
10084                      boolean if you want to see current command number
10085   cpan_home          local directory reserved for this package
10086   curl               path to external prg
10087   dontload_hash      DEPRECATED
10088   dontload_list      arrayref: modules in the list will not be
10089                      loaded by the CPAN::has_inst() routine
10090   ftp                path to external prg
10091   ftp_passive        if set, the envariable FTP_PASSIVE is set for downloads
10092   ftp_proxy          proxy host for ftp requests
10093   getcwd             see below
10094   gpg                path to external prg
10095   gzip               location of external program gzip
10096   histfile           file to maintain history between sessions
10097   histsize           maximum number of lines to keep in histfile
10098   http_proxy         proxy host for http requests
10099   inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
10100                      after this many seconds inactivity. Set to 0 to
10101                      never break.
10102   index_expire       after this many days refetch index files
10103   inhibit_startup_message
10104                      if true, does not print the startup message
10105   keep_source_where  directory in which to keep the source (if we do)
10106   lynx               path to external prg
10107   make               location of external make program
10108   make_arg           arguments that should always be passed to 'make'
10109   make_install_make_command
10110                      the make command for running 'make install', for
10111                      example 'sudo make'
10112   make_install_arg   same as make_arg for 'make install'
10113   makepl_arg         arguments passed to 'perl Makefile.PL'
10114   mbuild_arg         arguments passed to './Build'
10115   mbuild_install_arg arguments passed to './Build install'
10116   mbuild_install_build_command
10117                      command to use instead of './Build' when we are
10118                      in the install stage, for example 'sudo ./Build'
10119   mbuildpl_arg       arguments passed to 'perl Build.PL'
10120   ncftp              path to external prg
10121   ncftpget           path to external prg
10122   no_proxy           don't proxy to these hosts/domains (comma separated list)
10123   pager              location of external program more (or any pager)
10124   password           your password if you CPAN server wants one
10125   patch              path to external prg
10126   prefer_installer   legal values are MB and EUMM: if a module comes
10127                      with both a Makefile.PL and a Build.PL, use the
10128                      former (EUMM) or the latter (MB); if the module
10129                      comes with only one of the two, that one will be
10130                      used in any case
10131   prerequisites_policy
10132                      what to do if you are missing module prerequisites
10133                      ('follow' automatically, 'ask' me, or 'ignore')
10134   prefs_dir          local directory to store per-distro build options
10135   proxy_user         username for accessing an authenticating proxy
10136   proxy_pass         password for accessing an authenticating proxy
10137   randomize_urllist  add some randomness to the sequence of the urllist
10138   scan_cache         controls scanning of cache ('atstart' or 'never')
10139   shell              your favorite shell
10140   show_upload_date   boolean if commands should try to determine upload date
10141   tar                location of external program tar
10142   term_is_latin      if true internal UTF-8 is translated to ISO-8859-1
10143                      (and nonsense for characters outside latin range)
10144   term_ornaments     boolean to turn ReadLine ornamenting on/off
10145   test_report        email test reports (if CPAN::Reporter is installed)
10146   unzip              location of external program unzip
10147   urllist            arrayref to nearby CPAN sites (or equivalent locations)
10148   use_sqlite         use CPAN::SQLite for metadata storage (fast and lean)
10149   username           your username if you CPAN server wants one
10150   wait_list          arrayref to a wait server to try (See CPAN::WAIT)
10151   wget               path to external prg
10152   yaml_module        which module to use to read/write YAML files
10153
10154 You can set and query each of these options interactively in the cpan
10155 shell with the command set defined within the C<o conf> command:
10156
10157 =over 2
10158
10159 =item C<o conf E<lt>scalar optionE<gt>>
10160
10161 prints the current value of the I<scalar option>
10162
10163 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
10164
10165 Sets the value of the I<scalar option> to I<value>
10166
10167 =item C<o conf E<lt>list optionE<gt>>
10168
10169 prints the current value of the I<list option> in MakeMaker's
10170 neatvalue format.
10171
10172 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
10173
10174 shifts or pops the array in the I<list option> variable
10175
10176 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
10177
10178 works like the corresponding perl commands.
10179
10180 =back
10181
10182 =head2 CPAN::anycwd($path): Note on config variable getcwd
10183
10184 CPAN.pm changes the current working directory often and needs to
10185 determine its own current working directory. Per default it uses
10186 Cwd::cwd but if this doesn't work on your system for some reason,
10187 alternatives can be configured according to the following table:
10188
10189 =over 2
10190
10191 =item cwd
10192
10193 Calls Cwd::cwd
10194
10195 =item getcwd
10196
10197 Calls Cwd::getcwd
10198
10199 =item fastcwd
10200
10201 Calls Cwd::fastcwd
10202
10203 =item backtickcwd
10204
10205 Calls the external command cwd.
10206
10207 =back
10208
10209 =head2 Note on the format of the urllist parameter
10210
10211 urllist parameters are URLs according to RFC 1738. We do a little
10212 guessing if your URL is not compliant, but if you have problems with
10213 C<file> URLs, please try the correct format. Either:
10214
10215     file://localhost/whatever/ftp/pub/CPAN/
10216
10217 or
10218
10219     file:///home/ftp/pub/CPAN/
10220
10221 =head2 urllist parameter has CD-ROM support
10222
10223 The C<urllist> parameter of the configuration table contains a list of
10224 URLs that are to be used for downloading. If the list contains any
10225 C<file> URLs, CPAN always tries to get files from there first. This
10226 feature is disabled for index files. So the recommendation for the
10227 owner of a CD-ROM with CPAN contents is: include your local, possibly
10228 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
10229
10230   o conf urllist push file://localhost/CDROM/CPAN
10231
10232 CPAN.pm will then fetch the index files from one of the CPAN sites
10233 that come at the beginning of urllist. It will later check for each
10234 module if there is a local copy of the most recent version.
10235
10236 Another peculiarity of urllist is that the site that we could
10237 successfully fetch the last file from automatically gets a preference
10238 token and is tried as the first site for the next request. So if you
10239 add a new site at runtime it may happen that the previously preferred
10240 site will be tried another time. This means that if you want to disallow
10241 a site for the next transfer, it must be explicitly removed from
10242 urllist.
10243
10244 =head2 Maintaining the urllist parameter
10245
10246 If you have YAML.pm (or some other YAML module configured in
10247 C<yaml_module>) installed, CPAN.pm collects a few statistical data
10248 about recent downloads. You can view the statistics with the C<hosts>
10249 command or inspect them directly by looking into the C<FTPstats.yml>
10250 file in your C<cpan_home> directory.
10251
10252 To get some interesting statistics it is recommended to set the
10253 C<randomize_urllist> parameter that introduces some amount of
10254 randomness into the URL selection.
10255
10256 =head2 prefs_dir for avoiding interactive questions (ALPHA)
10257
10258 (B<Note:> This feature has been introduced in CPAN.pm 1.8854 and is
10259 still considered experimental and may still be changed)
10260
10261 The files in the directory specified in C<prefs_dir> are YAML files
10262 that specify how CPAN.pm shall treat distributions that deviate from
10263 the normal non-interactive model of building and installing CPAN
10264 modules.
10265
10266 Some modules try to get some data from the user interactively thus
10267 disturbing the installation of large bundles like Phalanx100 or
10268 modules like Plagger.
10269
10270 CPAN.pm can use YAML files to either pass additional arguments to one
10271 of the four commands, set environment variables or instantiate an
10272 Expect object that reads from the console and enters answers on your
10273 behalf (latter option requires Expect.pm installed). A further option
10274 is to apply patches from the local disk or from CPAN.
10275
10276 CPAN.pm comes with a couple of such YAML files. The structure is
10277 currently not documented because in flux. Please see the distroprefs
10278 directory of the CPAN distribution for examples and follow the README
10279 in there.
10280
10281 Please note that setting the environment variable PERL_MM_USE_DEFAULT
10282 to a true value can also get you a long way if you want to always pick
10283 the default answers. But this only works if the author of a package
10284 used the prompt function provided by ExtUtils::MakeMaker and if the
10285 defaults are OK for you.
10286
10287 =head1 SECURITY
10288
10289 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
10290 install foreign, unmasked, unsigned code on your machine. We compare
10291 to a checksum that comes from the net just as the distribution file
10292 itself. But we try to make it easy to add security on demand:
10293
10294 =head2 Cryptographically signed modules
10295
10296 Since release 1.77 CPAN.pm has been able to verify cryptographically
10297 signed module distributions using Module::Signature.  The CPAN modules
10298 can be signed by their authors, thus giving more security.  The simple
10299 unsigned MD5 checksums that were used before by CPAN protect mainly
10300 against accidental file corruption.
10301
10302 You will need to have Module::Signature installed, which in turn
10303 requires that you have at least one of Crypt::OpenPGP module or the
10304 command-line F<gpg> tool installed.
10305
10306 You will also need to be able to connect over the Internet to the public
10307 keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
10308
10309 The configuration parameter check_sigs is there to turn signature
10310 checking on or off.
10311
10312 =head1 EXPORT
10313
10314 Most functions in package CPAN are exported per default. The reason
10315 for this is that the primary use is intended for the cpan shell or for
10316 one-liners.
10317
10318 =head1 ENVIRONMENT
10319
10320 When the CPAN shell enters a subshell via the look command, it sets
10321 the environment CPAN_SHELL_LEVEL to 1 or increments it if it is
10322 already set.
10323
10324 When CPAN runs, it sets the environment variable PERL5_CPAN_IS_RUNNING.
10325
10326 When the config variable ftp_passive is set, all downloads will be run
10327 with the environment variable FTP_PASSIVE set to this value. This is
10328 in general a good idea as it influences both Net::FTP and LWP based
10329 connections. The same effect can be achieved by starting the cpan
10330 shell with this environment variable set. For Net::FTP alone, one can
10331 also always set passive mode by running libnetcfg.
10332
10333 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
10334
10335 Populating a freshly installed perl with my favorite modules is pretty
10336 easy if you maintain a private bundle definition file. To get a useful
10337 blueprint of a bundle definition file, the command autobundle can be used
10338 on the CPAN shell command line. This command writes a bundle definition
10339 file for all modules that are installed for the currently running perl
10340 interpreter. It's recommended to run this command only once and from then
10341 on maintain the file manually under a private name, say
10342 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
10343
10344     cpan> install Bundle::my_bundle
10345
10346 then answer a few questions and then go out for a coffee.
10347
10348 Maintaining a bundle definition file means keeping track of two
10349 things: dependencies and interactivity. CPAN.pm sometimes fails on
10350 calculating dependencies because not all modules define all MakeMaker
10351 attributes correctly, so a bundle definition file should specify
10352 prerequisites as early as possible. On the other hand, it's a bit
10353 annoying that many distributions need some interactive configuring. So
10354 what I try to accomplish in my private bundle file is to have the
10355 packages that need to be configured early in the file and the gentle
10356 ones later, so I can go out after a few minutes and leave CPAN.pm
10357 untended.
10358
10359 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
10360
10361 Thanks to Graham Barr for contributing the following paragraphs about
10362 the interaction between perl, and various firewall configurations. For
10363 further information on firewalls, it is recommended to consult the
10364 documentation that comes with the ncftp program. If you are unable to
10365 go through the firewall with a simple Perl setup, it is very likely
10366 that you can configure ncftp so that it works for your firewall.
10367
10368 =head2 Three basic types of firewalls
10369
10370 Firewalls can be categorized into three basic types.
10371
10372 =over 4
10373
10374 =item http firewall
10375
10376 This is where the firewall machine runs a web server and to access the
10377 outside world you must do it via the web server. If you set environment
10378 variables like http_proxy or ftp_proxy to a values beginning with http://
10379 or in your web browser you have to set proxy information then you know
10380 you are running an http firewall.
10381
10382 To access servers outside these types of firewalls with perl (even for
10383 ftp) you will need to use LWP.
10384
10385 =item ftp firewall
10386
10387 This where the firewall machine runs an ftp server. This kind of
10388 firewall will only let you access ftp servers outside the firewall.
10389 This is usually done by connecting to the firewall with ftp, then
10390 entering a username like "user@outside.host.com"
10391
10392 To access servers outside these type of firewalls with perl you
10393 will need to use Net::FTP.
10394
10395 =item One way visibility
10396
10397 I say one way visibility as these firewalls try to make themselves look
10398 invisible to the users inside the firewall. An FTP data connection is
10399 normally created by sending the remote server your IP address and then
10400 listening for the connection. But the remote server will not be able to
10401 connect to you because of the firewall. So for these types of firewall
10402 FTP connections need to be done in a passive mode.
10403
10404 There are two that I can think off.
10405
10406 =over 4
10407
10408 =item SOCKS
10409
10410 If you are using a SOCKS firewall you will need to compile perl and link
10411 it with the SOCKS library, this is what is normally called a 'socksified'
10412 perl. With this executable you will be able to connect to servers outside
10413 the firewall as if it is not there.
10414
10415 =item IP Masquerade
10416
10417 This is the firewall implemented in the Linux kernel, it allows you to
10418 hide a complete network behind one IP address. With this firewall no
10419 special compiling is needed as you can access hosts directly.
10420
10421 For accessing ftp servers behind such firewalls you usually need to
10422 set the environment variable C<FTP_PASSIVE> or the config variable
10423 ftp_passive to a true value.
10424
10425 =back
10426
10427 =back
10428
10429 =head2 Configuring lynx or ncftp for going through a firewall
10430
10431 If you can go through your firewall with e.g. lynx, presumably with a
10432 command such as
10433
10434     /usr/local/bin/lynx -pscott:tiger
10435
10436 then you would configure CPAN.pm with the command
10437
10438     o conf lynx "/usr/local/bin/lynx -pscott:tiger"
10439
10440 That's all. Similarly for ncftp or ftp, you would configure something
10441 like
10442
10443     o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
10444
10445 Your mileage may vary...
10446
10447 =head1 FAQ
10448
10449 =over 4
10450
10451 =item 1)
10452
10453 I installed a new version of module X but CPAN keeps saying,
10454 I have the old version installed
10455
10456 Most probably you B<do> have the old version installed. This can
10457 happen if a module installs itself into a different directory in the
10458 @INC path than it was previously installed. This is not really a
10459 CPAN.pm problem, you would have the same problem when installing the
10460 module manually. The easiest way to prevent this behaviour is to add
10461 the argument C<UNINST=1> to the C<make install> call, and that is why
10462 many people add this argument permanently by configuring
10463
10464   o conf make_install_arg UNINST=1
10465
10466 =item 2)
10467
10468 So why is UNINST=1 not the default?
10469
10470 Because there are people who have their precise expectations about who
10471 may install where in the @INC path and who uses which @INC array. In
10472 fine tuned environments C<UNINST=1> can cause damage.
10473
10474 =item 3)
10475
10476 I want to clean up my mess, and install a new perl along with
10477 all modules I have. How do I go about it?
10478
10479 Run the autobundle command for your old perl and optionally rename the
10480 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
10481 with the Configure option prefix, e.g.
10482
10483     ./Configure -Dprefix=/usr/local/perl-5.6.78.9
10484
10485 Install the bundle file you produced in the first step with something like
10486
10487     cpan> install Bundle::mybundle
10488
10489 and you're done.
10490
10491 =item 4)
10492
10493 When I install bundles or multiple modules with one command
10494 there is too much output to keep track of.
10495
10496 You may want to configure something like
10497
10498   o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
10499   o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
10500
10501 so that STDOUT is captured in a file for later inspection.
10502
10503
10504 =item 5)
10505
10506 I am not root, how can I install a module in a personal directory?
10507
10508 First of all, you will want to use your own configuration, not the one
10509 that your root user installed. If you do not have permission to write
10510 in the cpan directory that root has configured, you will be asked if
10511 you want to create your own config. Answering "yes" will bring you into
10512 CPAN's configuration stage, using the system config for all defaults except
10513 things that have to do with CPAN's work directory, saving your choices to
10514 your MyConfig.pm file.
10515
10516 You can also manually initiate this process with the following command:
10517
10518     % perl -MCPAN -e 'mkmyconfig'
10519
10520 or by running
10521
10522     mkmyconfig
10523
10524 from the CPAN shell.
10525
10526 You will most probably also want to configure something like this:
10527
10528   o conf makepl_arg "LIB=~/myperl/lib \
10529                     INSTALLMAN1DIR=~/myperl/man/man1 \
10530                     INSTALLMAN3DIR=~/myperl/man/man3"
10531
10532 You can make this setting permanent like all C<o conf> settings with
10533 C<o conf commit>.
10534
10535 You will have to add ~/myperl/man to the MANPATH environment variable
10536 and also tell your perl programs to look into ~/myperl/lib, e.g. by
10537 including
10538
10539   use lib "$ENV{HOME}/myperl/lib";
10540
10541 or setting the PERL5LIB environment variable.
10542
10543 While we're speaking about $ENV{HOME}, it might be worth mentioning,
10544 that for Windows we use the File::HomeDir module that provides an
10545 equivalent to the concept of the home directory on Unix.
10546
10547 Another thing you should bear in mind is that the UNINST parameter can
10548 be dnagerous when you are installing into a private area because you
10549 might accidentally remove modules that other people depend on that are
10550 not using the private area.
10551
10552 =item 6)
10553
10554 How to get a package, unwrap it, and make a change before building it?
10555
10556 Have a look at the C<look> (!) command.
10557
10558 =item 7)
10559
10560 I installed a Bundle and had a couple of fails. When I
10561 retried, everything resolved nicely. Can this be fixed to work
10562 on first try?
10563
10564 The reason for this is that CPAN does not know the dependencies of all
10565 modules when it starts out. To decide about the additional items to
10566 install, it just uses data found in the META.yml file or the generated
10567 Makefile. An undetected missing piece breaks the process. But it may
10568 well be that your Bundle installs some prerequisite later than some
10569 depending item and thus your second try is able to resolve everything.
10570 Please note, CPAN.pm does not know the dependency tree in advance and
10571 cannot sort the queue of things to install in a topologically correct
10572 order. It resolves perfectly well IF all modules declare the
10573 prerequisites correctly with the PREREQ_PM attribute to MakeMaker or
10574 the C<requires> stanza of Module::Build. For bundles which fail and
10575 you need to install often, it is recommended to sort the Bundle
10576 definition file manually.
10577
10578 =item 8)
10579
10580 In our intranet we have many modules for internal use. How
10581 can I integrate these modules with CPAN.pm but without uploading
10582 the modules to CPAN?
10583
10584 Have a look at the CPAN::Site module.
10585
10586 =item 9)
10587
10588 When I run CPAN's shell, I get an error message about things in my
10589 /etc/inputrc (or ~/.inputrc) file.
10590
10591 These are readline issues and can only be fixed by studying readline
10592 configuration on your architecture and adjusting the referenced file
10593 accordingly. Please make a backup of the /etc/inputrc or ~/.inputrc
10594 and edit them. Quite often harmless changes like uppercasing or
10595 lowercasing some arguments solves the problem.
10596
10597 =item 10)
10598
10599 Some authors have strange characters in their names.
10600
10601 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
10602 expecting ISO-8859-1 charset, a converter can be activated by setting
10603 term_is_latin to a true value in your config file. One way of doing so
10604 would be
10605
10606     cpan> o conf term_is_latin 1
10607
10608 If other charset support is needed, please file a bugreport against
10609 CPAN.pm at rt.cpan.org and describe your needs. Maybe we can extend
10610 the support or maybe UTF-8 terminals become widely available.
10611
10612 =item 11)
10613
10614 When an install fails for some reason and then I correct the error
10615 condition and retry, CPAN.pm refuses to install the module, saying
10616 C<Already tried without success>.
10617
10618 Use the force pragma like so
10619
10620   force install Foo::Bar
10621
10622 This does a bit more than really needed because it untars the
10623 distribution again and runs make and test and only then install.
10624
10625 Or, if you find this is too fast and you would prefer to do smaller
10626 steps, say
10627
10628   force get Foo::Bar
10629
10630 first and then continue as always. C<Force get> I<forgets> previous
10631 error conditions.
10632
10633 Or you can use
10634
10635   look Foo::Bar
10636
10637 and then 'make install' directly in the subshell.
10638
10639 Or you leave the CPAN shell and start it again.
10640
10641 For the really curious, by accessing internals directly, you I<could>
10642
10643   !delete CPAN::Shell->expandany("Foo::Bar")->distribution->{install}
10644
10645 but this is neither guaranteed to work in the future nor is it a
10646 decent command.
10647
10648 =item 12)
10649
10650 How do I install a "DEVELOPER RELEASE" of a module?
10651
10652 By default, CPAN will install the latest non-developer release of a
10653 module. If you want to install a dev release, you have to specify the
10654 partial path starting with the author id to the tarball you wish to
10655 install, like so:
10656
10657     cpan> install KWILLIAMS/Module-Build-0.27_07.tar.gz
10658
10659 Note that you can use the C<ls> command to get this path listed.
10660
10661 =item 13)
10662
10663 How do I install a module and all its dependencies from the commandline,
10664 without being prompted for anything, despite my CPAN configuration
10665 (or lack thereof)?
10666
10667 CPAN uses ExtUtils::MakeMaker's prompt() function to ask its questions, so
10668 if you set the PERL_MM_USE_DEFAULT environment variable, you shouldn't be
10669 asked any questions at all (assuming the modules you are installing are
10670 nice about obeying that variable as well):
10671
10672     % PERL_MM_USE_DEFAULT=1 perl -MCPAN -e 'install My::Module'
10673
10674 =item 14)
10675
10676 How do I create a Module::Build based Build.PL derived from an
10677 ExtUtils::MakeMaker focused Makefile.PL?
10678
10679 http://search.cpan.org/search?query=Module::Build::Convert
10680
10681 http://accognoscere.org/papers/perl-module-build-convert/module-build-convert.html
10682
10683 =item 15)
10684
10685 What's the best CPAN site for me?
10686
10687 The urllist config parameter is yours. You can add and remove sites at
10688 will. You should find out which sites have the best uptodateness,
10689 bandwidth, reliability, etc. and are topologically close to you. Some
10690 people prefer fast downloads, others uptodateness, others reliability.
10691 You decide which to try in which order.
10692
10693 Henk P. Penning maintains a site that collects data about CPAN sites:
10694
10695   http://www.cs.uu.nl/people/henkp/mirmon/cpan.html
10696
10697 =back
10698
10699 =head1 BUGS
10700
10701 Please report bugs via http://rt.cpan.org/
10702
10703 Before submitting a bug, please make sure that the traditional method
10704 of building a Perl module package from a shell by following the
10705 installation instructions of that package still works in your
10706 environment.
10707
10708 =head1 SECURITY ADVICE
10709
10710 This software enables you to upgrade software on your computer and so
10711 is inherently dangerous because the newly installed software may
10712 contain bugs and may alter the way your computer works or even make it
10713 unusable. Please consider backing up your data before every upgrade.
10714
10715 =head1 AUTHOR
10716
10717 Andreas Koenig C<< <andk@cpan.org> >>
10718
10719 =head1 LICENSE
10720
10721 This program is free software; you can redistribute it and/or
10722 modify it under the same terms as Perl itself.
10723
10724 See L<http://www.perl.com/perl/misc/Artistic.html>
10725
10726 =head1 TRANSLATIONS
10727
10728 Kawai,Takanori provides a Japanese translation of this manpage at
10729 http://homepage3.nifty.com/hippo2000/perltips/CPAN.htm
10730
10731 =head1 SEE ALSO
10732
10733 cpan(1), CPAN::Nox(3pm), CPAN::Version(3pm)
10734
10735 =cut
10736
10737