lib/CPAN.pm

   1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
   2 use strict;
   3 package CPAN;
   4 $CPAN::VERSION = '1.88_63';
   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     # no strict; # I do not recall why no strict was here (2000-09-03)
 203     $META->checklock();
 204     my @cwd = grep { defined $_ and length $_ }
 205         CPAN::anycwd(),
 206               File::Spec->can("tmpdir") ? File::Spec->tmpdir() : (),
 207                     File::Spec->rootdir();
 208     my $try_detect_readline;
 209     $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
 210     my $rl_avail = $Suppress_readline ? "suppressed" :
 211         ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
 212             "available (try 'install Bundle::CPAN')";
 213
 214     unless ($CPAN::Config->{'inhibit_startup_message'}){
 215         $CPAN::Frontend->myprint(
 216                                  sprintf qq{
 217 cpan shell -- CPAN exploration and modules installation (v%s)
 218 ReadLine support %s
 219
 220 },
 221                                  $CPAN::VERSION,
 222                                  $rl_avail
 223                                 )
 224     }
 225     my($continuation) = "";
 226     my $last_term_ornaments;
 227   SHELLCOMMAND: while () {
 228         if ($Suppress_readline) {
 229             print $prompt;
 230             last SHELLCOMMAND unless defined ($_ = <> );
 231             chomp;
 232         } else {
 233             last SHELLCOMMAND unless
 234                 defined ($_ = $term->readline($prompt, $commandline));
 235         }
 236         $_ = "$continuation$_" if $continuation;
 237         s/^\s+//;
 238         next SHELLCOMMAND if /^$/;
 239         $_ = 'h' if /^\s*\?/;
 240         if (/^(?:q(?:uit)?|bye|exit)$/i) {
 241             last SHELLCOMMAND;
 242         } elsif (s/\\$//s) {
 243             chomp;
 244             $continuation = $_;
 245             $prompt = "    > ";
 246         } elsif (/^\!/) {
 247             s/^\!//;
 248             my($eval) = $_;
 249             package CPAN::Eval;
 250             use strict;
 251             use vars qw($import_done);
 252             CPAN->import(':DEFAULT') unless $import_done++;
 253             CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
 254             eval($eval);
 255             warn $@ if $@;
 256             $continuation = "";
 257             $prompt = $oprompt;
 258         } elsif (/./) {
 259             my(@line);
 260             eval { @line = Text::ParseWords::shellwords($_) };
 261             warn($@), next SHELLCOMMAND if $@;
 262             warn("Text::Parsewords could not parse the line [$_]"),
 263                 next SHELLCOMMAND unless @line;
 264             $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
 265             my $command = shift @line;
 266             eval { CPAN::Shell->$command(@line) };
 267             if ($@){
 268                 require Carp;
 269                 Carp::cluck($@);
 270             }
 271             if ($command =~ /^(make|test|install|force|notest|clean|report|upgrade)$/) {
 272                 CPAN::Shell->failed($CPAN::CurrentCommandId,1);
 273             }
 274             soft_chdir_with_alternatives(\@cwd);
 275             $CPAN::Frontend->myprint("\n");
 276             $continuation = "";
 277             $CPAN::CurrentCommandId++;
 278             $prompt = $oprompt;
 279         }
 280     } continue {
 281       $commandline = ""; # I do want to be able to pass a default to
 282                          # shell, but on the second command I see no
 283                          # use in that
 284       $Signal=0;
 285       CPAN::Queue->nullify_queue;
 286       if ($try_detect_readline) {
 287         if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
 288             ||
 289             $CPAN::META->has_inst("Term::ReadLine::Perl")
 290            ) {
 291             delete $INC{"Term/ReadLine.pm"};
 292             my $redef = 0;
 293             local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
 294             require Term::ReadLine;
 295             $CPAN::Frontend->myprint("\n$redef subroutines in ".
 296                                      "Term::ReadLine redefined\n");
 297             $GOTOSHELL = 1;
 298         }
 299       }
 300       if ($term and $term->can("ornaments")) {
 301           for ($CPAN::Config->{term_ornaments}) { # alias
 302               if (defined $_) {
 303                   if (not defined $last_term_ornaments
 304                       or $_ != $last_term_ornaments
 305                      ) {
 306                       local $Term::ReadLine::termcap_nowarn = 1;
 307                       $term->ornaments($_);
 308                       $last_term_ornaments = $_;
 309                   }
 310               } else {
 311                   undef $last_term_ornaments;
 312               }
 313           }
 314       }
 315       for my $class (qw(Module Distribution)) {
 316           # again unsafe meta access?
 317           for my $dm (keys %{$CPAN::META->{readwrite}{"CPAN::$class"}}) {
 318               next unless $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
 319               CPAN->debug("BUG: $class '$dm' was in command state, resetting");
 320               delete $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
 321           }
 322       }
 323       if ($GOTOSHELL) {
 324           $GOTOSHELL = 0; # not too often
 325           $META->savehist if $CPAN::term && $CPAN::term->can("GetHistory");
 326           @_ = ($oprompt,"");
 327           goto &shell;
 328       }
 329     }
 330     soft_chdir_with_alternatives(\@cwd);
 331 }
 332
 333 sub soft_chdir_with_alternatives ($) {
 334     my($cwd) = @_;
 335     unless (@$cwd) {
 336         my $root = File::Spec->rootdir();
 337         $CPAN::Frontend->mywarn(qq{Warning: no good directory to chdir to!
 338 Trying '$root' as temporary haven.
 339 });
 340         push @$cwd, $root;
 341     }
 342     while () {
 343         if (chdir $cwd->[0]) {
 344             return;
 345         } else {
 346             if (@$cwd>1) {
 347                 $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $!
 348 Trying to chdir to "$cwd->[1]" instead.
 349 });
 350                 shift @$cwd;
 351             } else {
 352                 $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!});
 353             }
 354         }
 355     }
 356 }
 357
 358 sub _yaml_module {
 359     my $yaml_module = $CPAN::Config->{yaml_module} || "YAML";
 360     if (
 361         $yaml_module ne "YAML"
 362         &&
 363         !$CPAN::META->has_inst($yaml_module)
 364        ) {
 365         # $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back to 'YAML'\n");
 366         $yaml_module = "YAML";
 367     }
 368     return $yaml_module;
 369 }
 370
 371 # CPAN::_yaml_loadfile
 372 sub _yaml_loadfile {
 373     my($self,$local_file) = @_;
 374     return +[] unless -s $local_file;
 375     my $yaml_module = $self->_yaml_module;
 376     if ($CPAN::META->has_inst($yaml_module)) {
 377         my $code = UNIVERSAL::can($yaml_module, "LoadFile");
 378         my @yaml;
 379         eval { @yaml = $code->($local_file); };
 380         if ($@) {
 381             $CPAN::Frontend->mydie("Alert: While trying to parse YAML file\n".
 382                                    "  $local_file\n".
 383                                    "with $yaml_module the following error was encountered:\n".
 384                                    "  $@\n"
 385                                   );
 386         }
 387         return \@yaml;
 388     } else {
 389         $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot parse '$local_file'\n");
 390     }
 391     return +[];
 392 }
 393
 394 # CPAN::_yaml_dumpfile
 395 sub _yaml_dumpfile {
 396     my($self,$to_local_file,@what) = @_;
 397     my $yaml_module = $self->_yaml_module;
 398     if ($CPAN::META->has_inst($yaml_module)) {
 399         if (UNIVERSAL::isa($to_local_file, "FileHandle")) {
 400             my $code = UNIVERSAL::can($yaml_module, "Dump");
 401             eval { print $to_local_file $code->(@what) };
 402         } else {
 403             my $code = UNIVERSAL::can($yaml_module, "DumpFile");
 404             eval { $code->($to_local_file,@what); };
 405         }
 406         if ($@) {
 407             $CPAN::Frontend->mydie("Alert: While trying to dump YAML file\n".
 408                                    "  $to_local_file\n".
 409                                    "with $yaml_module the following error was encountered:\n".
 410                                    "  $@\n"
 411                                   );
 412         }
 413     } else {
 414         if (UNIVERSAL::isa($to_local_file, "FileHandle")) {
 415             # I think this case does not justify a warning at all
 416         } else {
 417             $CPAN::Frontend->myprint("Note (usually harmless): '$yaml_module' ".
 418                                      "not installed, not dumping to '$to_local_file'\n");
 419         }
 420     }
 421 }
 422
 423 sub _init_sqlite () {
 424     unless ($CPAN::META->has_inst("CPAN::SQLite")
 425             &&
 426             $CPAN::META->has_inst("CPAN::SQLite::META")
 427            ) {
 428         $CPAN::Frontend->mywarn(qq{SQLite not installed, cannot work with CPAN::SQLite});
 429         return;
 430     }
 431     $CPAN::SQLite ||= CPAN::SQLite::META->new($CPAN::META);
 432 }
 433
 434 package CPAN::CacheMgr;
 435 use strict;
 436 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
 437 use File::Find;
 438
 439 package CPAN::FTP;
 440 use strict;
 441 use Fcntl qw(:flock);
 442 use vars qw($Ua $Thesite $ThesiteURL $Themethod);
 443 @CPAN::FTP::ISA = qw(CPAN::Debug);
 444
 445 package CPAN::LWP::UserAgent;
 446 use strict;
 447 use vars qw(@ISA $USER $PASSWD $SETUPDONE);
 448 # we delay requiring LWP::UserAgent and setting up inheritance until we need it
 449
 450 package CPAN::Complete;
 451 use strict;
 452 @CPAN::Complete::ISA = qw(CPAN::Debug);
 453 # Q: where is the "How do I add a new command" HOWTO?
 454 # A: svn diff -r 1048:1049 where andk added the report command
 455 @CPAN::Complete::COMMANDS = sort qw(
 456                                     ! a b d h i m o q r u
 457                                     autobundle
 458                                     clean
 459                                     cvs_import
 460                                     dump
 461                                     force
 462                                     hosts
 463                                     install
 464                                     install_tested
 465                                     look
 466                                     ls
 467                                     make
 468                                     mkmyconfig
 469                                     notest
 470                                     perldoc
 471                                     readme
 472                                     recent
 473                                     recompile
 474                                     reload
 475                                     report
 476                                     scripts
 477                                     test
 478                                     upgrade
 479 );
 480
 481 package CPAN::Index;
 482 use strict;
 483 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED);
 484 @CPAN::Index::ISA = qw(CPAN::Debug);
 485 $LAST_TIME ||= 0;
 486 $DATE_OF_03 ||= 0;
 487 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
 488 sub PROTOCOL { 2.0 }
 489
 490 package CPAN::InfoObj;
 491 use strict;
 492 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
 493
 494 package CPAN::Author;
 495 use strict;
 496 @CPAN::Author::ISA = qw(CPAN::InfoObj);
 497
 498 package CPAN::Distribution;
 499 use strict;
 500 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
 501
 502 package CPAN::Bundle;
 503 use strict;
 504 @CPAN::Bundle::ISA = qw(CPAN::Module);
 505
 506 package CPAN::Module;
 507 use strict;
 508 @CPAN::Module::ISA = qw(CPAN::InfoObj);
 509
 510 package CPAN::Exception::RecursiveDependency;
 511 use strict;
 512 use overload '""' => "as_string";
 513
 514 sub new {
 515     my($class) = shift;
 516     my($deps) = shift;
 517     my @deps;
 518     my %seen;
 519     for my $dep (@$deps) {
 520         push @deps, $dep;
 521         last if $seen{$dep}++;
 522     }
 523     bless { deps => \@deps }, $class;
 524 }
 525
 526 sub as_string {
 527     my($self) = shift;
 528     "\nRecursive dependency detected:\n    " .
 529         join("\n => ", @{$self->{deps}}) .
 530             ".\nCannot continue.\n";
 531 }
 532
 533 package CPAN::Prompt; use overload '""' => "as_string";
 534 use vars qw($prompt);
 535 $prompt = "cpan> ";
 536 $CPAN::CurrentCommandId ||= 0;
 537 sub new {
 538     bless {}, shift;
 539 }
 540 sub as_string {
 541     my $word = "cpan";
 542     unless ($CPAN::META->{LOCK}) {
 543         $word = "nolock_cpan";
 544     }
 545     if ($CPAN::Config->{commandnumber_in_prompt}) {
 546         sprintf "$word\[%d]> ", $CPAN::CurrentCommandId;
 547     } else {
 548         "$word> ";
 549     }
 550 }
 551
 552 package CPAN::URL; use overload '""' => "as_string", fallback => 1;
 553 # accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist),
 554 # planned are things like age or quality
 555 sub new {
 556     my($class,%args) = @_;
 557     bless {
 558            %args
 559           }, $class;
 560 }
 561 sub as_string {
 562     my($self) = @_;
 563     $self->text;
 564 }
 565 sub text {
 566     my($self,$set) = @_;
 567     if (defined $set) {
 568         $self->{TEXT} = $set;
 569     }
 570     $self->{TEXT};
 571 }
 572
 573 package CPAN::Distrostatus;
 574 use overload '""' => "as_string",
 575     fallback => 1;
 576 sub new {
 577     my($class,$arg) = @_;
 578     bless {
 579            TEXT => $arg,
 580            FAILED => substr($arg,0,2) eq "NO",
 581            COMMANDID => $CPAN::CurrentCommandId,
 582            TIME => time,
 583           }, $class;
 584 }
 585 sub commandid { shift->{COMMANDID} }
 586 sub failed { shift->{FAILED} }
 587 sub text {
 588     my($self,$set) = @_;
 589     if (defined $set) {
 590         $self->{TEXT} = $set;
 591     }
 592     $self->{TEXT};
 593 }
 594 sub as_string {
 595     my($self) = @_;
 596     $self->text;
 597 }
 598
 599 package CPAN::Shell;
 600 use strict;
 601 use vars qw(
 602             $ADVANCED_QUERY
 603             $AUTOLOAD
 604             $COLOR_REGISTERED
 605             $autoload_recursion
 606             $reload
 607             @ISA
 608            );
 609 @CPAN::Shell::ISA = qw(CPAN::Debug);
 610 $COLOR_REGISTERED ||= 0;
 611
 612 {
 613     $autoload_recursion   ||= 0;
 614
 615     #-> sub CPAN::Shell::AUTOLOAD ;
 616     sub AUTOLOAD {
 617         $autoload_recursion++;
 618         my($l) = $AUTOLOAD;
 619         my $class = shift(@_);
 620         # warn "autoload[$l] class[$class]";
 621         $l =~ s/.*:://;
 622         if ($CPAN::Signal) {
 623             warn "Refusing to autoload '$l' while signal pending";
 624             $autoload_recursion--;
 625             return;
 626         }
 627         if ($autoload_recursion > 1) {
 628             my $fullcommand = join " ", map { "'$_'" } $l, @_;
 629             warn "Refusing to autoload $fullcommand in recursion\n";
 630             $autoload_recursion--;
 631             return;
 632         }
 633         if ($l =~ /^w/) {
 634             # XXX needs to be reconsidered
 635             if ($CPAN::META->has_inst('CPAN::WAIT')) {
 636                 CPAN::WAIT->$l(@_);
 637             } else {
 638                 $CPAN::Frontend->mywarn(qq{
 639 Commands starting with "w" require CPAN::WAIT to be installed.
 640 Please consider installing CPAN::WAIT to use the fulltext index.
 641 For this you just need to type
 642     install CPAN::WAIT
 643 });
 644             }
 645         } else {
 646             $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }.
 647                                     qq{Type ? for help.
 648 });
 649         }
 650         $autoload_recursion--;
 651     }
 652 }
 653
 654 package CPAN;
 655 use strict;
 656
 657 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
 658
 659 # from here on only subs.
 660 ################################################################################
 661
 662 sub _perl_fingerprint {
 663     my($self,$other_fingerprint) = @_;
 664     my $dll = eval {OS2::DLLname()};
 665     my $mtime_dll = 0;
 666     if (defined $dll) {
 667         $mtime_dll = (-f $dll ? (stat(_))[9] : '-1');
 668     }
 669     my $this_fingerprint = {
 670                             '$^X' => $^X,
 671                             sitearchexp => $Config::Config{sitearchexp},
 672                             'mtime_$^X' => (stat $^X)[9],
 673                             'mtime_dll' => $mtime_dll,
 674                            };
 675     if ($other_fingerprint) {
 676         if (exists $other_fingerprint->{'stat($^X)'}) { # repair fp from rev. 1.88_57
 677             $other_fingerprint->{'mtime_$^X'} = $other_fingerprint->{'stat($^X)'}[9];
 678         }
 679         # mandatory keys since 1.88_57
 680         for my $key (qw($^X sitearchexp mtime_dll mtime_$^X)) {
 681             return unless $other_fingerprint->{$key} eq $this_fingerprint->{$key};
 682         }
 683         return 1;
 684     } else {
 685         return $this_fingerprint;
 686     }
 687 }
 688
 689 sub suggest_myconfig () {
 690   SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) {
 691         $CPAN::Frontend->myprint("You don't seem to have a user ".
 692                                  "configuration (MyConfig.pm) yet.\n");
 693         my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ".
 694                                               "user configuration now? (Y/n)",
 695                                               "yes");
 696         if($new =~ m{^y}i) {
 697             CPAN::Shell->mkmyconfig();
 698             return &checklock;
 699         } else {
 700             $CPAN::Frontend->mydie("OK, giving up.");
 701         }
 702     }
 703 }
 704
 705 #-> sub CPAN::all_objects ;
 706 sub all_objects {
 707     my($mgr,$class) = @_;
 708     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 709     CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
 710     CPAN::Index->reload;
 711     values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
 712 }
 713
 714 # Called by shell, not in batch mode. In batch mode I see no risk in
 715 # having many processes updating something as installations are
 716 # continually checked at runtime. In shell mode I suspect it is
 717 # unintentional to open more than one shell at a time
 718
 719 #-> sub CPAN::checklock ;
 720 sub checklock {
 721     my($self) = @_;
 722     my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
 723     if (-f $lockfile && -M _ > 0) {
 724         my $fh = FileHandle->new($lockfile) or
 725             $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
 726         my $otherpid  = <$fh>;
 727         my $otherhost = <$fh>;
 728         $fh->close;
 729         if (defined $otherpid && $otherpid) {
 730             chomp $otherpid;
 731         }
 732         if (defined $otherhost && $otherhost) {
 733             chomp $otherhost;
 734         }
 735         my $thishost  = hostname();
 736         if (defined $otherhost && defined $thishost &&
 737             $otherhost ne '' && $thishost ne '' &&
 738             $otherhost ne $thishost) {
 739             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
 740                                            "reports other host $otherhost and other ".
 741                                            "process $otherpid.\n".
 742                                            "Cannot proceed.\n"));
 743         } elsif ($RUN_DEGRADED) {
 744             $CPAN::Frontend->mywarn("Running in degraded mode (experimental)\n");
 745         } elsif (defined $otherpid && $otherpid) {
 746             return if $$ == $otherpid; # should never happen
 747             $CPAN::Frontend->mywarn(
 748                                     qq{
 749 There seems to be running another CPAN process (pid $otherpid).  Contacting...
 750 });
 751             if (kill 0, $otherpid) {
 752                 $CPAN::Frontend->mywarn(qq{Other job is running.\n});
 753                 my($ans) =
 754                     CPAN::Shell::colorable_makemaker_prompt
 755                         (qq{Shall I try to run in degraded }.
 756                          qq{mode? (Y/n)},"y");
 757                 if ($ans =~ /^y/i) {
 758                     $CPAN::Frontend->mywarn("Running in degraded mode (experimental).
 759 Please report if something unexpected happens\n");
 760                     $RUN_DEGRADED = 1;
 761                     for ($CPAN::Config) {
 762                         # XXX
 763                         # $_->{build_dir_reuse} = 0; # 2006-11-17 akoenig Why was that?
 764                         $_->{commandnumber_in_prompt} = 0; # visibility
 765                         $_->{histfile} = "";               # who should win otherwise?
 766                         $_->{cache_metadata} = 0;          # better would be a lock?
 767                     }
 768                 } else {
 769                     $CPAN::Frontend->mydie("
 770 You may want to kill the other job and delete the lockfile. On UNIX try:
 771     kill $otherpid
 772     rm $lockfile
 773 ");
 774                 }
 775             } elsif (-w $lockfile) {
 776                 my($ans) =
 777                     CPAN::Shell::colorable_makemaker_prompt
 778                         (qq{Other job not responding. Shall I overwrite }.
 779                          qq{the lockfile '$lockfile'? (Y/n)},"y");
 780                 $CPAN::Frontend->myexit("Ok, bye\n")
 781                     unless $ans =~ /^y/i;
 782             } else {
 783                 Carp::croak(
 784                             qq{Lockfile '$lockfile' not writeable by you. }.
 785                             qq{Cannot proceed.\n}.
 786                             qq{    On UNIX try:\n}.
 787                             qq{    rm '$lockfile'\n}.
 788                             qq{  and then rerun us.\n}
 789                            );
 790             }
 791         } else {
 792             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Found invalid lockfile ".
 793                                            "'$lockfile', please remove. Cannot proceed.\n"));
 794         }
 795     }
 796     my $dotcpan = $CPAN::Config->{cpan_home};
 797     eval { File::Path::mkpath($dotcpan);};
 798     if ($@) {
 799         # A special case at least for Jarkko.
 800         my $firsterror = $@;
 801         my $seconderror;
 802         my $symlinkcpan;
 803         if (-l $dotcpan) {
 804             $symlinkcpan = readlink $dotcpan;
 805             die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
 806             eval { File::Path::mkpath($symlinkcpan); };
 807             if ($@) {
 808                 $seconderror = $@;
 809             } else {
 810                 $CPAN::Frontend->mywarn(qq{
 811 Working directory $symlinkcpan created.
 812 });
 813             }
 814         }
 815         unless (-d $dotcpan) {
 816             my $mess = qq{
 817 Your configuration suggests "$dotcpan" as your
 818 CPAN.pm working directory. I could not create this directory due
 819 to this error: $firsterror\n};
 820             $mess .= qq{
 821 As "$dotcpan" is a symlink to "$symlinkcpan",
 822 I tried to create that, but I failed with this error: $seconderror
 823 } if $seconderror;
 824             $mess .= qq{
 825 Please make sure the directory exists and is writable.
 826 };
 827             $CPAN::Frontend->myprint($mess);
 828             return suggest_myconfig;
 829         }
 830     } # $@ after eval mkpath $dotcpan
 831     if (0) { # to test what happens when a race condition occurs
 832         for (reverse 1..10) {
 833             print $_, "\n";
 834             sleep 1;
 835         }
 836     }
 837     # locking
 838     if (!$RUN_DEGRADED && !$self->{LOCKFH}) {
 839         my $fh;
 840         unless ($fh = FileHandle->new("+>>$lockfile")) {
 841             if ($! =~ /Permission/) {
 842                 $CPAN::Frontend->myprint(qq{
 843
 844 Your configuration suggests that CPAN.pm should use a working
 845 directory of
 846     $CPAN::Config->{cpan_home}
 847 Unfortunately we could not create the lock file
 848     $lockfile
 849 due to permission problems.
 850
 851 Please make sure that the configuration variable
 852     \$CPAN::Config->{cpan_home}
 853 points to a directory where you can write a .lock file. You can set
 854 this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
 855 \@INC path;
 856 });
 857                 return suggest_myconfig;
 858             }
 859         }
 860         my $sleep = 1;
 861         while (!flock $fh, LOCK_EX|LOCK_NB) {
 862             if ($sleep>10) {
 863                 $CPAN::Frontend->mydie("Giving up\n");
 864             }
 865             $CPAN::Frontend->mysleep($sleep++);
 866             $CPAN::Frontend->mywarn("Could not lock lockfile with flock: $!; retrying\n");
 867         }
 868
 869         seek $fh, 0, 0;
 870         truncate $fh, 0;
 871         $fh->print($$, "\n");
 872         $fh->print(hostname(), "\n");
 873         $self->{LOCK} = $lockfile;
 874         $self->{LOCKFH} = $fh;
 875     }
 876     $SIG{TERM} = sub {
 877         my $sig = shift;
 878         &cleanup;
 879         $CPAN::Frontend->mydie("Got SIG$sig, leaving");
 880     };
 881     $SIG{INT} = sub {
 882       # no blocks!!!
 883         my $sig = shift;
 884         &cleanup if $Signal;
 885         die "Got yet another signal" if $Signal > 1;
 886         $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal;
 887         $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n");
 888         $Signal++;
 889     };
 890
 891 #       From: Larry Wall <larry@wall.org>
 892 #       Subject: Re: deprecating SIGDIE
 893 #       To: perl5-porters@perl.org
 894 #       Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
 895 #
 896 #       The original intent of __DIE__ was only to allow you to substitute one
 897 #       kind of death for another on an application-wide basis without respect
 898 #       to whether you were in an eval or not.  As a global backstop, it should
 899 #       not be used any more lightly (or any more heavily :-) than class
 900 #       UNIVERSAL.  Any attempt to build a general exception model on it should
 901 #       be politely squashed.  Any bug that causes every eval {} to have to be
 902 #       modified should be not so politely squashed.
 903 #
 904 #       Those are my current opinions.  It is also my optinion that polite
 905 #       arguments degenerate to personal arguments far too frequently, and that
 906 #       when they do, it's because both people wanted it to, or at least didn't
 907 #       sufficiently want it not to.
 908 #
 909 #       Larry
 910
 911     # global backstop to cleanup if we should really die
 912     $SIG{__DIE__} = \&cleanup;
 913     $self->debug("Signal handler set.") if $CPAN::DEBUG;
 914 }
 915
 916 #-> sub CPAN::DESTROY ;
 917 sub DESTROY {
 918     &cleanup; # need an eval?
 919 }
 920
 921 #-> sub CPAN::anycwd ;
 922 sub anycwd () {
 923     my $getcwd;
 924     $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
 925     CPAN->$getcwd();
 926 }
 927
 928 #-> sub CPAN::cwd ;
 929 sub cwd {Cwd::cwd();}
 930
 931 #-> sub CPAN::getcwd ;
 932 sub getcwd {Cwd::getcwd();}
 933
 934 #-> sub CPAN::fastcwd ;
 935 sub fastcwd {Cwd::fastcwd();}
 936
 937 #-> sub CPAN::backtickcwd ;
 938 sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
 939
 940 #-> sub CPAN::find_perl ;
 941 sub find_perl {
 942     my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
 943     my $pwd  = $CPAN::iCwd = CPAN::anycwd();
 944     my $candidate = File::Spec->catfile($pwd,$^X);
 945     $perl ||= $candidate if MM->maybe_command($candidate);
 946
 947     unless ($perl) {
 948         my ($component,$perl_name);
 949       DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
 950             PATH_COMPONENT: foreach $component (File::Spec->path(),
 951                                                 $Config::Config{'binexp'}) {
 952                   next unless defined($component) && $component;
 953                   my($abs) = File::Spec->catfile($component,$perl_name);
 954                   if (MM->maybe_command($abs)) {
 955                       $perl = $abs;
 956                       last DIST_PERLNAME;
 957                   }
 958               }
 959           }
 960     }
 961
 962     return $perl;
 963 }
 964
 965
 966 #-> sub CPAN::exists ;
 967 sub exists {
 968     my($mgr,$class,$id) = @_;
 969     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 970     CPAN::Index->reload;
 971     ### Carp::croak "exists called without class argument" unless $class;
 972     $id ||= "";
 973     $id =~ s/:+/::/g if $class eq "CPAN::Module";
 974     if ($CPAN::Config->{use_sqlite} && CPAN::_init_sqlite) { # not yet officially supported
 975         return (exists $META->{readonly}{$class}{$id} or
 976                 $CPAN::SQLite->set($class, $id));
 977     } else {
 978         return (exists $META->{readonly}{$class}{$id} or
 979                 exists $META->{readwrite}{$class}{$id}); # unsafe meta access, ok
 980     }
 981 }
 982
 983 #-> sub CPAN::delete ;
 984 sub delete {
 985   my($mgr,$class,$id) = @_;
 986   delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
 987   delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
 988 }
 989
 990 #-> sub CPAN::has_usable
 991 # has_inst is sometimes too optimistic, we should replace it with this
 992 # has_usable whenever a case is given
 993 sub has_usable {
 994     my($self,$mod,$message) = @_;
 995     return 1 if $HAS_USABLE->{$mod};
 996     my $has_inst = $self->has_inst($mod,$message);
 997     return unless $has_inst;
 998     my $usable;
 999     $usable = {
1000                LWP => [ # we frequently had "Can't locate object
1001                         # method "new" via package "LWP::UserAgent" at
1002                         # (eval 69) line 2006
1003                        sub {require LWP},
1004                        sub {require LWP::UserAgent},
1005                        sub {require HTTP::Request},
1006                        sub {require URI::URL},
1007                       ],
1008                'Net::FTP' => [
1009                             sub {require Net::FTP},
1010                             sub {require Net::Config},
1011                            ],
1012                'File::HomeDir' => [
1013                                    sub {require File::HomeDir;
1014                                         unless (File::HomeDir::->VERSION >= 0.52){
1015                                             for ("Will not use File::HomeDir, need 0.52\n") {
1016                                                 $CPAN::Frontend->mywarn($_);
1017                                                 die $_;
1018                                             }
1019                                         }
1020                                     },
1021                                   ],
1022               };
1023     if ($usable->{$mod}) {
1024         for my $c (0..$#{$usable->{$mod}}) {
1025             my $code = $usable->{$mod}[$c];
1026             my $ret = eval { &$code() };
1027             $ret = "" unless defined $ret;
1028             if ($@) {
1029                 # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
1030                 return;
1031             }
1032         }
1033     }
1034     return $HAS_USABLE->{$mod} = 1;
1035 }
1036
1037 #-> sub CPAN::has_inst
1038 sub has_inst {
1039     my($self,$mod,$message) = @_;
1040     Carp::croak("CPAN->has_inst() called without an argument")
1041         unless defined $mod;
1042     my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
1043         keys %{$CPAN::Config->{dontload_hash}||{}},
1044             @{$CPAN::Config->{dontload_list}||[]};
1045     if (defined $message && $message eq "no"  # afair only used by Nox
1046         ||
1047         $dont{$mod}
1048        ) {
1049       $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
1050       return 0;
1051     }
1052     my $file = $mod;
1053     my $obj;
1054     $file =~ s|::|/|g;
1055     $file .= ".pm";
1056     if ($INC{$file}) {
1057         # checking %INC is wrong, because $INC{LWP} may be true
1058         # although $INC{"URI/URL.pm"} may have failed. But as
1059         # I really want to say "bla loaded OK", I have to somehow
1060         # cache results.
1061         ### warn "$file in %INC"; #debug
1062         return 1;
1063     } elsif (eval { require $file }) {
1064         # eval is good: if we haven't yet read the database it's
1065         # perfect and if we have installed the module in the meantime,
1066         # it tries again. The second require is only a NOOP returning
1067         # 1 if we had success, otherwise it's retrying
1068
1069         my $v = eval "\$$mod\::VERSION";
1070         $v = $v ? " (v$v)" : "";
1071         $CPAN::Frontend->myprint("CPAN: $mod loaded ok$v\n");
1072         if ($mod eq "CPAN::WAIT") {
1073             push @CPAN::Shell::ISA, 'CPAN::WAIT';
1074         }
1075         return 1;
1076     } elsif ($mod eq "Net::FTP") {
1077         $CPAN::Frontend->mywarn(qq{
1078   Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
1079   if you just type
1080       install Bundle::libnet
1081
1082 }) unless $Have_warned->{"Net::FTP"}++;
1083         $CPAN::Frontend->mysleep(3);
1084     } elsif ($mod eq "Digest::SHA"){
1085         if ($Have_warned->{"Digest::SHA"}++) {
1086             $CPAN::Frontend->myprint(qq{CPAN: checksum security checks disabled}.
1087                                      qq{because Digest::SHA not installed.\n});
1088         } else {
1089             $CPAN::Frontend->mywarn(qq{
1090   CPAN: checksum security checks disabled because Digest::SHA not installed.
1091   Please consider installing the Digest::SHA module.
1092
1093 });
1094             $CPAN::Frontend->mysleep(2);
1095         }
1096     } elsif ($mod eq "Module::Signature"){
1097         # NOT prefs_lookup, we are not a distro
1098         my $check_sigs = $CPAN::Config->{check_sigs};
1099         if (not $check_sigs) {
1100             # they do not want us:-(
1101         } elsif (not $Have_warned->{"Module::Signature"}++) {
1102             # No point in complaining unless the user can
1103             # reasonably install and use it.
1104             if (eval { require Crypt::OpenPGP; 1 } ||
1105                 (
1106                  defined $CPAN::Config->{'gpg'}
1107                  &&
1108                  $CPAN::Config->{'gpg'} =~ /\S/
1109                 )
1110                ) {
1111                 $CPAN::Frontend->mywarn(qq{
1112   CPAN: Module::Signature security checks disabled because Module::Signature
1113   not installed.  Please consider installing the Module::Signature module.
1114   You may also need to be able to connect over the Internet to the public
1115   keyservers like pgp.mit.edu (port 11371).
1116
1117 });
1118                 $CPAN::Frontend->mysleep(2);
1119             }
1120         }
1121     } else {
1122         delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
1123     }
1124     return 0;
1125 }
1126
1127 #-> sub CPAN::instance ;
1128 sub instance {
1129     my($mgr,$class,$id) = @_;
1130     CPAN::Index->reload;
1131     $id ||= "";
1132     # unsafe meta access, ok?
1133     return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
1134     $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
1135 }
1136
1137 #-> sub CPAN::new ;
1138 sub new {
1139     bless {}, shift;
1140 }
1141
1142 #-> sub CPAN::cleanup ;
1143 sub cleanup {
1144   # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
1145   local $SIG{__DIE__} = '';
1146   my($message) = @_;
1147   my $i = 0;
1148   my $ineval = 0;
1149   my($subroutine);
1150   while ((undef,undef,undef,$subroutine) = caller(++$i)) {
1151       $ineval = 1, last if
1152           $subroutine eq '(eval)';
1153   }
1154   return if $ineval && !$CPAN::End;
1155   return unless defined $META->{LOCK};
1156   return unless -f $META->{LOCK};
1157   $META->savehist;
1158   unlink $META->{LOCK};
1159   # require Carp;
1160   # Carp::cluck("DEBUGGING");
1161   if ( $CPAN::CONFIG_DIRTY ) {
1162       $CPAN::Frontend->mywarn("Warning: Configuration not saved.\n");
1163   }
1164   $CPAN::Frontend->myprint("Lockfile removed.\n");
1165 }
1166
1167 #-> sub CPAN::savehist
1168 sub savehist {
1169     my($self) = @_;
1170     my($histfile,$histsize);
1171     unless ($histfile = $CPAN::Config->{'histfile'}){
1172         $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
1173         return;
1174     }
1175     $histsize = $CPAN::Config->{'histsize'} || 100;
1176     if ($CPAN::term){
1177         unless ($CPAN::term->can("GetHistory")) {
1178             $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
1179             return;
1180         }
1181     } else {
1182         return;
1183     }
1184     my @h = $CPAN::term->GetHistory;
1185     splice @h, 0, @h-$histsize if @h>$histsize;
1186     my($fh) = FileHandle->new;
1187     open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
1188     local $\ = local $, = "\n";
1189     print $fh @h;
1190     close $fh;
1191 }
1192
1193 #-> sub CPAN::is_tested
1194 sub is_tested {
1195     my($self,$what) = @_;
1196     $self->{is_tested}{$what} = 1;
1197 }
1198
1199 #-> sub CPAN::is_installed
1200 # unsets the is_tested flag: as soon as the thing is installed, it is
1201 # not needed in set_perl5lib anymore
1202 sub is_installed {
1203     my($self,$what) = @_;
1204     delete $self->{is_tested}{$what};
1205 }
1206
1207 #-> sub CPAN::set_perl5lib
1208 sub set_perl5lib {
1209     my($self,$for) = @_;
1210     unless ($for) {
1211         (undef,undef,undef,$for) = caller(1);
1212         $for =~ s/.*://;
1213     }
1214     $self->{is_tested} ||= {};
1215     return unless %{$self->{is_tested}};
1216     my $env = $ENV{PERL5LIB};
1217     $env = $ENV{PERLLIB} unless defined $env;
1218     my @env;
1219     push @env, $env if defined $env and length $env;
1220     #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
1221     #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
1222     my @dirs = map {("$_/blib/arch", "$_/blib/lib")} sort keys %{$self->{is_tested}};
1223     if (@dirs < 15) {
1224         $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB for $for\n");
1225     } else {
1226         my @d = map {s/^\Q$CPAN::Config->{'build_dir'}/%BUILDDIR%/; $_ }
1227             sort keys %{$self->{is_tested}};
1228         $CPAN::Frontend->myprint("Prepending blib/arch and blib/lib subdirs of ".
1229                                  "@d to PERL5LIB; ".
1230                                  "%BUILDDIR%=$CPAN::Config->{'build_dir'} ".
1231                                  "for $for\n"
1232                                 );
1233     }
1234
1235     $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1236 }
1237
1238 package CPAN::CacheMgr;
1239 use strict;
1240
1241 #-> sub CPAN::CacheMgr::as_string ;
1242 sub as_string {
1243     eval { require Data::Dumper };
1244     if ($@) {
1245         return shift->SUPER::as_string;
1246     } else {
1247         return Data::Dumper::Dumper(shift);
1248     }
1249 }
1250
1251 #-> sub CPAN::CacheMgr::cachesize ;
1252 sub cachesize {
1253     shift->{DU};
1254 }
1255
1256 #-> sub CPAN::CacheMgr::tidyup ;
1257 sub tidyup {
1258   my($self) = @_;
1259   return unless $CPAN::META->{LOCK};
1260   return unless -d $self->{ID};
1261   while ($self->{DU} > $self->{'MAX'} ) {
1262     my($toremove) = shift @{$self->{FIFO}};
1263     $CPAN::Frontend->myprint(sprintf(
1264                                      "Deleting from cache".
1265                                      ": $toremove (%.1f>%.1f MB)\n",
1266                                      $self->{DU}, $self->{'MAX'})
1267                             );
1268     return if $CPAN::Signal;
1269     $self->force_clean_cache($toremove);
1270     return if $CPAN::Signal;
1271   }
1272 }
1273
1274 #-> sub CPAN::CacheMgr::dir ;
1275 sub dir {
1276     shift->{ID};
1277 }
1278
1279 #-> sub CPAN::CacheMgr::entries ;
1280 sub entries {
1281     my($self,$dir) = @_;
1282     return unless defined $dir;
1283     $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
1284     $dir ||= $self->{ID};
1285     my($cwd) = CPAN::anycwd();
1286     chdir $dir or Carp::croak("Can't chdir to $dir: $!");
1287     my $dh = DirHandle->new(File::Spec->curdir)
1288         or Carp::croak("Couldn't opendir $dir: $!");
1289     my(@entries);
1290     for ($dh->read) {
1291         next if $_ eq "." || $_ eq "..";
1292         if (-f $_) {
1293             push @entries, File::Spec->catfile($dir,$_);
1294         } elsif (-d _) {
1295             push @entries, File::Spec->catdir($dir,$_);
1296         } else {
1297             $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
1298         }
1299     }
1300     chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
1301     sort { -M $b <=> -M $a} @entries;
1302 }
1303
1304 #-> sub CPAN::CacheMgr::disk_usage ;
1305 sub disk_usage {
1306     my($self,$dir) = @_;
1307     return if exists $self->{SIZE}{$dir};
1308     return if $CPAN::Signal;
1309     my($Du) = 0;
1310     if (-e $dir) {
1311         unless (-x $dir) {
1312             unless (chmod 0755, $dir) {
1313                 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
1314                                         "permission to change the permission; cannot ".
1315                                         "estimate disk usage of '$dir'\n");
1316                 $CPAN::Frontend->mysleep(5);
1317                 return;
1318             }
1319         }
1320     } else {
1321         $CPAN::Frontend->mywarn("Directory '$dir' has gone. Cannot continue.\n");
1322         return;
1323     }
1324     find(
1325          sub {
1326            $File::Find::prune++ if $CPAN::Signal;
1327            return if -l $_;
1328            if ($^O eq 'MacOS') {
1329              require Mac::Files;
1330              my $cat  = Mac::Files::FSpGetCatInfo($_);
1331              $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
1332            } else {
1333              if (-d _) {
1334                unless (-x _) {
1335                  unless (chmod 0755, $_) {
1336                    $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
1337                                            "the permission to change the permission; ".
1338                                            "can only partially estimate disk usage ".
1339                                            "of '$_'\n");
1340                    $CPAN::Frontend->mysleep(5);
1341                    return;
1342                  }
1343                }
1344              } else {
1345                $Du += (-s _);
1346              }
1347            }
1348          },
1349          $dir
1350         );
1351     return if $CPAN::Signal;
1352     $self->{SIZE}{$dir} = $Du/1024/1024;
1353     push @{$self->{FIFO}}, $dir;
1354     $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
1355     $self->{DU} += $Du/1024/1024;
1356     $self->{DU};
1357 }
1358
1359 #-> sub CPAN::CacheMgr::force_clean_cache ;
1360 sub force_clean_cache {
1361     my($self,$dir) = @_;
1362     return unless -e $dir;
1363     unless (File::Basename::dirname($dir) eq $CPAN::Config->{build_dir}) {
1364         $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
1365                                 "will not remove\n");
1366         $CPAN::Frontend->mysleep(5);
1367         return;
1368     }
1369     $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
1370         if $CPAN::DEBUG;
1371     File::Path::rmtree($dir);
1372     unlink "$dir.yml"; # may fail
1373     $self->{DU} -= $self->{SIZE}{$dir};
1374     delete $self->{SIZE}{$dir};
1375 }
1376
1377 #-> sub CPAN::CacheMgr::new ;
1378 sub new {
1379     my $class = shift;
1380     my $time = time;
1381     my($debug,$t2);
1382     $debug = "";
1383     my $self = {
1384                 ID => $CPAN::Config->{'build_dir'},
1385                 MAX => $CPAN::Config->{'build_cache'},
1386                 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
1387                 DU => 0
1388                };
1389     File::Path::mkpath($self->{ID});
1390     my $dh = DirHandle->new($self->{ID});
1391     bless $self, $class;
1392     $self->scan_cache;
1393     $t2 = time;
1394     $debug .= "timing of CacheMgr->new: ".($t2 - $time);
1395     $time = $t2;
1396     CPAN->debug($debug) if $CPAN::DEBUG;
1397     $self;
1398 }
1399
1400 #-> sub CPAN::CacheMgr::scan_cache ;
1401 sub scan_cache {
1402     my $self = shift;
1403     return if $self->{SCAN} eq 'never';
1404     $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
1405         unless $self->{SCAN} eq 'atstart';
1406     $CPAN::Frontend->myprint(
1407                              sprintf("Scanning cache %s for sizes\n",
1408                                      $self->{ID}));
1409     my $e;
1410     for $e ($self->entries($self->{ID})) {
1411         next if $e eq ".." || $e eq ".";
1412         $self->disk_usage($e);
1413         return if $CPAN::Signal;
1414     }
1415     $self->tidyup;
1416 }
1417
1418 package CPAN::Shell;
1419 use strict;
1420
1421 #-> sub CPAN::Shell::h ;
1422 sub h {
1423     my($class,$about) = @_;
1424     if (defined $about) {
1425         $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1426     } else {
1427         my $filler = " " x (80 - 28 - length($CPAN::VERSION));
1428         $CPAN::Frontend->myprint(qq{
1429 Display Information $filler (ver $CPAN::VERSION)
1430  command  argument          description
1431  a,b,d,m  WORD or /REGEXP/  about authors, bundles, distributions, modules
1432  i        WORD or /REGEXP/  about any of the above
1433  ls       AUTHOR or GLOB    about files in the author's directory
1434     (with WORD being a module, bundle or author name or a distribution
1435     name of the form AUTHOR/DISTRIBUTION)
1436
1437 Download, Test, Make, Install...
1438  get      download                     clean    make clean
1439  make     make (implies get)           look     open subshell in dist directory
1440  test     make test (implies make)     readme   display these README files
1441  install  make install (implies test)  perldoc  display POD documentation
1442
1443 Upgrade
1444  r        WORDs or /REGEXP/ or NONE    report updates for some/matching/all modules
1445  upgrade  WORDs or /REGEXP/ or NONE    upgrade some/matching/all modules
1446
1447 Pragmas
1448  force COMMAND    unconditionally do command
1449  notest COMMAND   skip testing
1450
1451 Other
1452  h,?           display this menu       ! perl-code   eval a perl command
1453  o conf [opt]  set and query options   q             quit the cpan shell
1454  reload cpan   load CPAN.pm again      reload index  load newer indices
1455  autobundle    Snapshot                recent        latest CPAN uploads});
1456 }
1457 }
1458
1459 *help = \&h;
1460
1461 #-> sub CPAN::Shell::a ;
1462 sub a {
1463   my($self,@arg) = @_;
1464   # authors are always UPPERCASE
1465   for (@arg) {
1466     $_ = uc $_ unless /=/;
1467   }
1468   $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1469 }
1470
1471 #-> sub CPAN::Shell::globls ;
1472 sub globls {
1473     my($self,$s,$pragmas) = @_;
1474     # ls is really very different, but we had it once as an ordinary
1475     # command in the Shell (upto rev. 321) and we could not handle
1476     # force well then
1477     my(@accept,@preexpand);
1478     if ($s =~ /[\*\?\/]/) {
1479         if ($CPAN::META->has_inst("Text::Glob")) {
1480             if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
1481                 my $rau = Text::Glob::glob_to_regex(uc $au);
1482                 CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
1483                       if $CPAN::DEBUG;
1484                 push @preexpand, map { $_->id . "/" . $pathglob }
1485                     CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
1486             } else {
1487                 my $rau = Text::Glob::glob_to_regex(uc $s);
1488                 push @preexpand, map { $_->id }
1489                     CPAN::Shell->expand_by_method('CPAN::Author',
1490                                                   ['id'],
1491                                                   "/$rau/");
1492             }
1493         } else {
1494             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
1495         }
1496     } else {
1497         push @preexpand, uc $s;
1498     }
1499     for (@preexpand) {
1500         unless (/^[A-Z0-9\-]+(\/|$)/i) {
1501             $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
1502             next;
1503         }
1504         push @accept, $_;
1505     }
1506     my $silent = @accept>1;
1507     my $last_alpha = "";
1508     my @results;
1509     for my $a (@accept){
1510         my($author,$pathglob);
1511         if ($a =~ m|(.*?)/(.*)|) {
1512             my $a2 = $1;
1513             $pathglob = $2;
1514             $author = CPAN::Shell->expand_by_method('CPAN::Author',
1515                                                     ['id'],
1516                                                     $a2) or die "No author found for $a2";
1517         } else {
1518             $author = CPAN::Shell->expand_by_method('CPAN::Author',
1519                                                     ['id'],
1520                                                     $a) or die "No author found for $a";
1521         }
1522         if ($silent) {
1523             my $alpha = substr $author->id, 0, 1;
1524             my $ad;
1525             if ($alpha eq $last_alpha) {
1526                 $ad = "";
1527             } else {
1528                 $ad = "[$alpha]";
1529                 $last_alpha = $alpha;
1530             }
1531             $CPAN::Frontend->myprint($ad);
1532         }
1533         for my $pragma (@$pragmas) {
1534             if ($author->can($pragma)) {
1535                 $author->$pragma();
1536             }
1537         }
1538         push @results, $author->ls($pathglob,$silent); # silent if
1539                                                        # more than one
1540                                                        # author
1541         for my $pragma (@$pragmas) {
1542             my $unpragma = "un$pragma";
1543             if ($author->can($unpragma)) {
1544                 $author->$unpragma();
1545             }
1546         }
1547     }
1548     @results;
1549 }
1550
1551 #-> sub CPAN::Shell::local_bundles ;
1552 sub local_bundles {
1553     my($self,@which) = @_;
1554     my($incdir,$bdir,$dh);
1555     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1556         my @bbase = "Bundle";
1557         while (my $bbase = shift @bbase) {
1558             $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
1559             CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1560             if ($dh = DirHandle->new($bdir)) { # may fail
1561                 my($entry);
1562                 for $entry ($dh->read) {
1563                     next if $entry =~ /^\./;
1564                     next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/;
1565                     if (-d File::Spec->catdir($bdir,$entry)){
1566                         push @bbase, "$bbase\::$entry";
1567                     } else {
1568                         next unless $entry =~ s/\.pm(?!\n)\Z//;
1569                         $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1570                     }
1571                 }
1572             }
1573         }
1574     }
1575 }
1576
1577 #-> sub CPAN::Shell::b ;
1578 sub b {
1579     my($self,@which) = @_;
1580     CPAN->debug("which[@which]") if $CPAN::DEBUG;
1581     $self->local_bundles;
1582     $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1583 }
1584
1585 #-> sub CPAN::Shell::d ;
1586 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1587
1588 #-> sub CPAN::Shell::m ;
1589 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1590     my $self = shift;
1591     $CPAN::Frontend->myprint($self->format_result('Module',@_));
1592 }
1593
1594 #-> sub CPAN::Shell::i ;
1595 sub i {
1596     my($self) = shift;
1597     my(@args) = @_;
1598     @args = '/./' unless @args;
1599     my(@result);
1600     for my $type (qw/Bundle Distribution Module/) {
1601         push @result, $self->expand($type,@args);
1602     }
1603     # Authors are always uppercase.
1604     push @result, $self->expand("Author", map { uc $_ } @args);
1605
1606     my $result = @result == 1 ?
1607         $result[0]->as_string :
1608             @result == 0 ?
1609                 "No objects found of any type for argument @args\n" :
1610                     join("",
1611                          (map {$_->as_glimpse} @result),
1612                          scalar @result, " items found\n",
1613                         );
1614     $CPAN::Frontend->myprint($result);
1615 }
1616
1617 #-> sub CPAN::Shell::o ;
1618
1619 # CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o
1620 # conf' calls through to CPAN::HandleConfig::edit. 'o conf' should
1621 # probably have been called 'set' and 'o debug' maybe 'set debug' or
1622 # 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm
1623 sub o {
1624     my($self,$o_type,@o_what) = @_;
1625     $o_type ||= "";
1626     CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1627     if ($o_type eq 'conf') {
1628         if (!@o_what) { # print all things, "o conf"
1629             my($k,$v);
1630             $CPAN::Frontend->myprint("\$CPAN::Config options from ");
1631             my @from;
1632             if (exists $INC{'CPAN/Config.pm'}) {
1633                 push @from, $INC{'CPAN/Config.pm'};
1634             }
1635             if (exists $INC{'CPAN/MyConfig.pm'}) {
1636                 push @from, $INC{'CPAN/MyConfig.pm'};
1637             }
1638             $CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from);
1639             $CPAN::Frontend->myprint(":\n");
1640             for $k (sort keys %CPAN::HandleConfig::can) {
1641                 $v = $CPAN::HandleConfig::can{$k};
1642                 $CPAN::Frontend->myprint(sprintf "    %-18s [%s]\n", $k, $v);
1643             }
1644             $CPAN::Frontend->myprint("\n");
1645             for $k (sort keys %$CPAN::Config) {
1646                 CPAN::HandleConfig->prettyprint($k);
1647             }
1648             $CPAN::Frontend->myprint("\n");
1649         } else {
1650             if (CPAN::HandleConfig->edit(@o_what)) {
1651                 unless ($o_what[0] =~ /^(init|commit|defaults)$/) {
1652                     $CPAN::Frontend->myprint("Please use 'o conf commit' to ".
1653                                              "make the config permanent!\n\n");
1654                 }
1655             } else {
1656                 $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
1657                                          qq{items\n\n});
1658             }
1659         }
1660     } elsif ($o_type eq 'debug') {
1661         my(%valid);
1662         @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1663         if (@o_what) {
1664             while (@o_what) {
1665                 my($what) = shift @o_what;
1666                 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
1667                     $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
1668                     next;
1669                 }
1670                 if ( exists $CPAN::DEBUG{$what} ) {
1671                     $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1672                 } elsif ($what =~ /^\d/) {
1673                     $CPAN::DEBUG = $what;
1674                 } elsif (lc $what eq 'all') {
1675                     my($max) = 0;
1676                     for (values %CPAN::DEBUG) {
1677                         $max += $_;
1678                     }
1679                     $CPAN::DEBUG = $max;
1680                 } else {
1681                     my($known) = 0;
1682                     for (keys %CPAN::DEBUG) {
1683                         next unless lc($_) eq lc($what);
1684                         $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1685                         $known = 1;
1686                     }
1687                     $CPAN::Frontend->myprint("unknown argument [$what]\n")
1688                         unless $known;
1689                 }
1690             }
1691         } else {
1692           my $raw = "Valid options for debug are ".
1693               join(", ",sort(keys %CPAN::DEBUG), 'all').
1694                   qq{ or a number. Completion works on the options. }.
1695                       qq{Case is ignored.};
1696           require Text::Wrap;
1697           $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1698           $CPAN::Frontend->myprint("\n\n");
1699         }
1700         if ($CPAN::DEBUG) {
1701             $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n");
1702             my($k,$v);
1703             for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1704                 $v = $CPAN::DEBUG{$k};
1705                 $CPAN::Frontend->myprint(sprintf "    %-14s(%s)\n", $k, $v)
1706                     if $v & $CPAN::DEBUG;
1707             }
1708         } else {
1709             $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1710         }
1711     } else {
1712         $CPAN::Frontend->myprint(qq{
1713 Known options:
1714   conf    set or get configuration variables
1715   debug   set or get debugging options
1716 });
1717     }
1718 }
1719
1720 # CPAN::Shell::paintdots_onreload
1721 sub paintdots_onreload {
1722     my($ref) = shift;
1723     sub {
1724         if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
1725             my($subr) = $1;
1726             ++$$ref;
1727             local($|) = 1;
1728             # $CPAN::Frontend->myprint(".($subr)");
1729             $CPAN::Frontend->myprint(".");
1730             if ($subr =~ /\bshell\b/i) {
1731                 # warn "debug[$_[0]]";
1732
1733                 # It would be nice if we could detect that a
1734                 # subroutine has actually changed, but for now we
1735                 # practically always set the GOTOSHELL global
1736
1737                 $CPAN::GOTOSHELL=1;
1738             }
1739             return;
1740         }
1741         warn @_;
1742     };
1743 }
1744
1745 #-> sub CPAN::Shell::hosts ;
1746 sub hosts {
1747     my($self) = @_;
1748     my $fullstats = CPAN::FTP->_ftp_statistics();
1749     my $history = $fullstats->{history} || [];
1750     my %S; # statistics
1751     while (my $last = pop @$history) {
1752         my $attempts = $last->{attempts} or next;
1753         my $start;
1754         if (@$attempts) {
1755             $start = $attempts->[-1]{start};
1756             if ($#$attempts > 0) {
1757                 for my $i (0..$#$attempts-1) {
1758                     my $url = $attempts->[$i]{url} or next;
1759                     $S{no}{$url}++;
1760                 }
1761             }
1762         } else {
1763             $start = $last->{start};
1764         }
1765         next unless $last->{thesiteurl}; # C-C? bad filenames?
1766         $S{start} = $start;
1767         $S{end} ||= $last->{end};
1768         my $dltime = $last->{end} - $start;
1769         my $dlsize = $last->{filesize} || 0;
1770         my $url = $last->{thesiteurl}->text;
1771         my $s = $S{ok}{$url} ||= {};
1772         $s->{n}++;
1773         $s->{dlsize} ||= 0;
1774         $s->{dlsize} += $dlsize/1024;
1775         $s->{dltime} ||= 0;
1776         $s->{dltime} += $dltime;
1777     }
1778     my $res;
1779     for my $url (keys %{$S{ok}}) {
1780         next if $S{ok}{$url}{dltime} == 0; # div by zero
1781         push @{$res->{ok}}, [@{$S{ok}{$url}}{qw(n dlsize dltime)},
1782                              $S{ok}{$url}{dlsize}/$S{ok}{$url}{dltime},
1783                              $url,
1784                             ];
1785     }
1786     for my $url (keys %{$S{no}}) {
1787         push @{$res->{no}}, [$S{no}{$url},
1788                              $url,
1789                             ];
1790     }
1791     my $R = ""; # report
1792     $R .= sprintf "Log starts: %s\n", scalar(localtime $S{start}) || "unknown";
1793     $R .= sprintf "Log ends  : %s\n", scalar(localtime $S{end}) || "unknown";
1794     if ($res->{ok} && @{$res->{ok}}) {
1795         $R .= sprintf "\nSuccessful downloads:
1796    N       kB  secs      kB/s url\n";
1797         my $i = 20;
1798         for (sort { $b->[3] <=> $a->[3] } @{$res->{ok}}) {
1799             $R .= sprintf "%4d %8d %5d %9.1f %s\n", @$_;
1800             last if --$i<=0;
1801         }
1802     }
1803     if ($res->{no} && @{$res->{no}}) {
1804         $R .= sprintf "\nUnsuccessful downloads:\n";
1805         my $i = 20;
1806         for (sort { $b->[0] <=> $a->[0] } @{$res->{no}}) {
1807             $R .= sprintf "%4d %s\n", @$_;
1808             last if --$i<=0;
1809         }
1810     }
1811     $CPAN::Frontend->myprint($R);
1812 }
1813
1814 #-> sub CPAN::Shell::reload ;
1815 sub reload {
1816     my($self,$command,@arg) = @_;
1817     $command ||= "";
1818     $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1819     if ($command =~ /^cpan$/i) {
1820         my $redef = 0;
1821         chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
1822         my $failed;
1823         my @relo = (
1824                     "CPAN.pm",
1825                     "CPAN/HandleConfig.pm",
1826                     "CPAN/FirstTime.pm",
1827                     "CPAN/Tarzip.pm",
1828                     "CPAN/Debug.pm",
1829                     "CPAN/Version.pm",
1830                     "CPAN/Queue.pm",
1831                     "CPAN/Reporter.pm",
1832                    );
1833       MFILE: for my $f (@relo) {
1834             next unless exists $INC{$f};
1835             my $p = $f;
1836             $p =~ s/\.pm$//;
1837             $p =~ s|/|::|g;
1838             $CPAN::Frontend->myprint("($p");
1839             local($SIG{__WARN__}) = paintdots_onreload(\$redef);
1840             $self->reload_this($f) or $failed++;
1841             my $v = eval "$p\::->VERSION";
1842             $CPAN::Frontend->myprint("v$v)");
1843         }
1844         $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1845         if ($failed) {
1846             my $errors = $failed == 1 ? "error" : "errors";
1847             $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ".
1848                                     "this session.\n");
1849         }
1850     } elsif ($command =~ /^index$/i) {
1851       CPAN::Index->force_reload;
1852     } else {
1853       $CPAN::Frontend->myprint(qq{cpan     re-evals the CPAN modules
1854 index    re-reads the index files\n});
1855     }
1856 }
1857
1858 # reload means only load again what we have loaded before
1859 #-> sub CPAN::Shell::reload_this ;
1860 sub reload_this {
1861     my($self,$f,$args) = @_;
1862     CPAN->debug("f[$f]") if $CPAN::DEBUG;
1863     return 1 unless $INC{$f}; # we never loaded this, so we do not
1864                               # reload but say OK
1865     my $pwd = CPAN::anycwd();
1866     CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG;
1867     my($file);
1868     for my $inc (@INC) {
1869         $file = File::Spec->catfile($inc,split /\//, $f);
1870         last if -f $file;
1871         $file = "";
1872     }
1873     CPAN->debug("file[$file]") if $CPAN::DEBUG;
1874     my @inc = @INC;
1875     unless ($file && -f $file) {
1876         # this thingie is not in the INC path, maybe CPAN/MyConfig.pm?
1877         $file = $INC{$f};
1878         unless (CPAN->has_inst("File::Basename")) {
1879             @inc = File::Basename::dirname($file);
1880         } else {
1881             # do we ever need this?
1882             @inc = substr($file,0,-length($f)-1); # bring in back to me!
1883         }
1884     }
1885     CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG;
1886     unless (-f $file) {
1887         $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
1888         return;
1889     }
1890     my $mtime = (stat $file)[9];
1891     $reload->{$f} ||= $^T;
1892     my $must_reload = $mtime > $reload->{$f};
1893     $args ||= {};
1894     $must_reload ||= $args->{force};
1895     if ($must_reload) {
1896         my $fh = FileHandle->new($file) or
1897             $CPAN::Frontend->mydie("Could not open $file: $!");
1898         local($/);
1899         local $^W = 1;
1900         my $content = <$fh>;
1901         CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
1902             if $CPAN::DEBUG;
1903         delete $INC{$f};
1904         local @INC = @inc;
1905         eval "require '$f'";
1906         if ($@){
1907             warn $@;
1908             return;
1909         }
1910         $reload->{$f} = time;
1911     } else {
1912         $CPAN::Frontend->myprint("__unchanged__");
1913     }
1914     return 1;
1915 }
1916
1917 #-> sub CPAN::Shell::mkmyconfig ;
1918 sub mkmyconfig {
1919     my($self, $cpanpm, %args) = @_;
1920     require CPAN::FirstTime;
1921     my $home = CPAN::HandleConfig::home;
1922     $cpanpm = $INC{'CPAN/MyConfig.pm'} ||
1923         File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm");
1924     File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm;
1925     CPAN::HandleConfig::require_myconfig_or_config;
1926     $CPAN::Config ||= {};
1927     $CPAN::Config = {
1928         %$CPAN::Config,
1929         build_dir           =>  undef,
1930         cpan_home           =>  undef,
1931         keep_source_where   =>  undef,
1932         histfile            =>  undef,
1933     };
1934     CPAN::FirstTime::init($cpanpm, %args);
1935 }
1936
1937 #-> sub CPAN::Shell::_binary_extensions ;
1938 sub _binary_extensions {
1939     my($self) = shift @_;
1940     my(@result,$module,%seen,%need,$headerdone);
1941     for $module ($self->expand('Module','/./')) {
1942         my $file  = $module->cpan_file;
1943         next if $file eq "N/A";
1944         next if $file =~ /^Contact Author/;
1945         my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
1946         next if $dist->isa_perl;
1947         next unless $module->xs_file;
1948         local($|) = 1;
1949         $CPAN::Frontend->myprint(".");
1950         push @result, $module;
1951     }
1952 #    print join " | ", @result;
1953     $CPAN::Frontend->myprint("\n");
1954     return @result;
1955 }
1956
1957 #-> sub CPAN::Shell::recompile ;
1958 sub recompile {
1959     my($self) = shift @_;
1960     my($module,@module,$cpan_file,%dist);
1961     @module = $self->_binary_extensions();
1962     for $module (@module){  # we force now and compile later, so we
1963                             # don't do it twice
1964         $cpan_file = $module->cpan_file;
1965         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1966         $pack->force;
1967         $dist{$cpan_file}++;
1968     }
1969     for $cpan_file (sort keys %dist) {
1970         $CPAN::Frontend->myprint("  CPAN: Recompiling $cpan_file\n\n");
1971         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1972         $pack->install;
1973         $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1974                            # stop a package from recompiling,
1975                            # e.g. IO-1.12 when we have perl5.003_10
1976     }
1977 }
1978
1979 #-> sub CPAN::Shell::scripts ;
1980 sub scripts {
1981     my($self, $arg) = @_;
1982     $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");
1983
1984     for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) {
1985         unless ($CPAN::META->has_inst($req)) {
1986             $CPAN::Frontend->mywarn("  $req not available\n");
1987         }
1988     }
1989     my $p = HTML::LinkExtor->new();
1990     my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html";
1991     unless (-f $indexfile) {
1992         $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n");
1993     }
1994     $p->parse_file($indexfile);
1995     my @hrefs;
1996     my $qrarg;
1997     if ($arg =~ s|^/(.+)/$|$1|) {
1998         $qrarg = eval 'qr/$arg/'; # hide construct from 5.004
1999     }
2000     for my $l ($p->links) {
2001         my $tag = shift @$l;
2002         next unless $tag eq "a";
2003         my %att = @$l;
2004         my $href = $att{href};
2005         next unless $href =~ s|^\.\./authors/id/./../||;
2006         if ($arg) {
2007             if ($qrarg) {
2008                 if ($href =~ $qrarg) {
2009                     push @hrefs, $href;
2010                 }
2011             } else {
2012                 if ($href =~ /\Q$arg\E/) {
2013                     push @hrefs, $href;
2014                 }
2015             }
2016         } else {
2017             push @hrefs, $href;
2018         }
2019     }
2020     # now filter for the latest version if there is more than one of a name
2021     my %stems;
2022     for (sort @hrefs) {
2023         my $href = $_;
2024         s/-v?\d.*//;
2025         my $stem = $_;
2026         $stems{$stem} ||= [];
2027         push @{$stems{$stem}}, $href;
2028     }
2029     for (sort keys %stems) {
2030         my $highest;
2031         if (@{$stems{$_}} > 1) {
2032             $highest = List::Util::reduce {
2033                 Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b
2034               } @{$stems{$_}};
2035         } else {
2036             $highest = $stems{$_}[0];
2037         }
2038         $CPAN::Frontend->myprint("$highest\n");
2039     }
2040 }
2041
2042 #-> sub CPAN::Shell::report ;
2043 sub report {
2044     my($self,@args) = @_;
2045     unless ($CPAN::META->has_inst("CPAN::Reporter")) {
2046         $CPAN::Frontend->mydie("CPAN::Reporter not installed; cannot continue");
2047     }
2048     local $CPAN::Config->{test_report} = 1;
2049     $self->force("test",@args); # force is there so that the test be
2050                                 # re-run (as documented)
2051 }
2052
2053 #-> sub CPAN::Shell::install_tested
2054 sub install_tested {
2055     my($self,@some) = @_;
2056     $CPAN::Frontend->mywarn("install_tested() requires no arguments.\n"),
2057         return if @some;
2058     CPAN::Index->reload;
2059
2060     for my $d (%{$CPAN::META->{readwrite}{'CPAN::Distribution'}}) {
2061         my $do = CPAN::Shell->expandany($d);
2062         next unless $do->{build_dir};
2063         push @some, $do;
2064     }
2065
2066     $CPAN::Frontend->mywarn("No tested distributions found.\n"),
2067         return unless @some;
2068
2069     @some = grep { $_->{make_test} && ! $_->{make_test}->failed } @some;
2070     $CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"),
2071         return unless @some;
2072
2073     @some = grep { not $_->uptodate } @some;
2074     $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"),
2075         return unless @some;
2076
2077     CPAN->debug("some[@some]");
2078     for my $d (@some) {
2079         my $id = $d->can("pretty_id") ? $d->pretty_id : $d->id;
2080         $CPAN::Frontend->myprint("install_tested: Running for $id\n");
2081         $CPAN::Frontend->sleep(1);
2082         $self->install($d);
2083     }
2084 }
2085
2086 #-> sub CPAN::Shell::upgrade ;
2087 sub upgrade {
2088     my($self,@args) = @_;
2089     $self->install($self->r(@args));
2090 }
2091
2092 #-> sub CPAN::Shell::_u_r_common ;
2093 sub _u_r_common {
2094     my($self) = shift @_;
2095     my($what) = shift @_;
2096     CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
2097     Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
2098           $what && $what =~ /^[aru]$/;
2099     my(@args) = @_;
2100     @args = '/./' unless @args;
2101     my(@result,$module,%seen,%need,$headerdone,
2102        $version_undefs,$version_zeroes);
2103     $version_undefs = $version_zeroes = 0;
2104     my $sprintf = "%s%-25s%s %9s %9s  %s\n";
2105     my @expand = $self->expand('Module',@args);
2106     my $expand = scalar @expand;
2107     if (0) { # Looks like noise to me, was very useful for debugging
2108              # for metadata cache
2109         $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
2110     }
2111   MODULE: for $module (@expand) {
2112         my $file  = $module->cpan_file;
2113         next MODULE unless defined $file; # ??
2114         $file =~ s|^./../||;
2115         my($latest) = $module->cpan_version;
2116         my($inst_file) = $module->inst_file;
2117         my($have);
2118         return if $CPAN::Signal;
2119         if ($inst_file){
2120             if ($what eq "a") {
2121                 $have = $module->inst_version;
2122             } elsif ($what eq "r") {
2123                 $have = $module->inst_version;
2124                 local($^W) = 0;
2125                 if ($have eq "undef"){
2126                     $version_undefs++;
2127                 } elsif ($have == 0){
2128                     $version_zeroes++;
2129                 }
2130                 next MODULE unless CPAN::Version->vgt($latest, $have);
2131 # to be pedantic we should probably say:
2132 #    && !($have eq "undef" && $latest ne "undef" && $latest gt "");
2133 # to catch the case where CPAN has a version 0 and we have a version undef
2134             } elsif ($what eq "u") {
2135                 next MODULE;
2136             }
2137         } else {
2138             if ($what eq "a") {
2139                 next MODULE;
2140             } elsif ($what eq "r") {
2141                 next MODULE;
2142             } elsif ($what eq "u") {
2143                 $have = "-";
2144             }
2145         }
2146         return if $CPAN::Signal; # this is sometimes lengthy
2147         $seen{$file} ||= 0;
2148         if ($what eq "a") {
2149             push @result, sprintf "%s %s\n", $module->id, $have;
2150         } elsif ($what eq "r") {
2151             push @result, $module->id;
2152             next MODULE if $seen{$file}++;
2153         } elsif ($what eq "u") {
2154             push @result, $module->id;
2155             next MODULE if $seen{$file}++;
2156             next MODULE if $file =~ /^Contact/;
2157         }
2158         unless ($headerdone++){
2159             $CPAN::Frontend->myprint("\n");
2160             $CPAN::Frontend->myprint(sprintf(
2161                                              $sprintf,
2162                                              "",
2163                                              "Package namespace",
2164                                              "",
2165                                              "installed",
2166                                              "latest",
2167                                              "in CPAN file"
2168                                             ));
2169         }
2170         my $color_on = "";
2171         my $color_off = "";
2172         if (
2173             $COLOR_REGISTERED
2174             &&
2175             $CPAN::META->has_inst("Term::ANSIColor")
2176             &&
2177             $module->description
2178            ) {
2179             $color_on = Term::ANSIColor::color("green");
2180             $color_off = Term::ANSIColor::color("reset");
2181         }
2182         $CPAN::Frontend->myprint(sprintf $sprintf,
2183                                  $color_on,
2184                                  $module->id,
2185                                  $color_off,
2186                                  $have,
2187                                  $latest,
2188                                  $file);
2189         $need{$module->id}++;
2190     }
2191     unless (%need) {
2192         if ($what eq "u") {
2193             $CPAN::Frontend->myprint("No modules found for @args\n");
2194         } elsif ($what eq "r") {
2195             $CPAN::Frontend->myprint("All modules are up to date for @args\n");
2196         }
2197     }
2198     if ($what eq "r") {
2199         if ($version_zeroes) {
2200             my $s_has = $version_zeroes > 1 ? "s have" : " has";
2201             $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
2202                 qq{a version number of 0\n});
2203         }
2204         if ($version_undefs) {
2205             my $s_has = $version_undefs > 1 ? "s have" : " has";
2206             $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
2207                 qq{parseable version number\n});
2208         }
2209     }
2210     @result;
2211 }
2212
2213 #-> sub CPAN::Shell::r ;
2214 sub r {
2215     shift->_u_r_common("r",@_);
2216 }
2217
2218 #-> sub CPAN::Shell::u ;
2219 sub u {
2220     shift->_u_r_common("u",@_);
2221 }
2222
2223 #-> sub CPAN::Shell::failed ;
2224 sub failed {
2225     my($self,$only_id,$silent) = @_;
2226     my @failed;
2227   DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
2228         my $failed = "";
2229       NAY: for my $nosayer (
2230                             "unwrapped",
2231                             "writemakefile",
2232                             "signature_verify",
2233                             "make",
2234                             "make_test",
2235                             "install",
2236                             "make_clean",
2237                            ) {
2238             next unless exists $d->{$nosayer};
2239             next unless defined $d->{$nosayer};
2240             next unless (
2241                          UNIVERSAL::can($d->{$nosayer},"failed") ?
2242                          $d->{$nosayer}->failed :
2243                          $d->{$nosayer} =~ /^NO/
2244                         );
2245             next NAY if $only_id && $only_id != (
2246                                                  UNIVERSAL::can($d->{$nosayer},"commandid")
2247                                                  ?
2248                                                  $d->{$nosayer}->commandid
2249                                                  :
2250                                                  $CPAN::CurrentCommandId
2251                                                 );
2252             $failed = $nosayer;
2253             last;
2254         }
2255         next DIST unless $failed;
2256         my $id = $d->id;
2257         $id =~ s|^./../||;
2258         #$print .= sprintf(
2259         #                  "  %-45s: %s %s\n",
2260         push @failed,
2261             (
2262              UNIVERSAL::can($d->{$failed},"failed") ?
2263              [
2264               $d->{$failed}->commandid,
2265               $id,
2266               $failed,
2267               $d->{$failed}->text,
2268               $d->{$failed}{TIME}||0,
2269              ] :
2270              [
2271               1,
2272               $id,
2273               $failed,
2274               $d->{$failed},
2275               0,
2276              ]
2277             );
2278     }
2279     my $scope;
2280     if ($only_id) {
2281         $scope = "this command";
2282     } elsif ($CPAN::Index::HAVE_REANIMATED) {
2283         $scope = "this or a previous session";
2284         # it might be nice to have a section for previous session and
2285         # a second for this
2286     } else {
2287         $scope = "this session";
2288     }
2289     if (@failed) {
2290         my $print;
2291         my $debug = 0;
2292         if ($debug) {
2293             $print = join "",
2294                 map { sprintf "%5d %-45s: %s %s\n", @$_ }
2295                     sort { $a->[0] <=> $b->[0] } @failed;
2296         } else {
2297             $print = join "",
2298                 map { sprintf " %-45s: %s %s\n", @$_[1..3] }
2299                     sort {
2300                         $a->[0] <=> $b->[0]
2301                             ||
2302                                 $a->[4] <=> $b->[4]
2303                        } @failed;
2304         }
2305         $CPAN::Frontend->myprint("Failed during $scope:\n$print");
2306     } elsif (!$only_id || !$silent) {
2307         $CPAN::Frontend->myprint("Nothing failed in $scope\n");
2308     }
2309 }
2310
2311 # XXX intentionally undocumented because completely bogus, unportable,
2312 # useless, etc.
2313
2314 #-> sub CPAN::Shell::status ;
2315 sub status {
2316     my($self) = @_;
2317     require Devel::Size;
2318     my $ps = FileHandle->new;
2319     open $ps, "/proc/$$/status";
2320     my $vm = 0;
2321     while (<$ps>) {
2322         next unless /VmSize:\s+(\d+)/;
2323         $vm = $1;
2324         last;
2325     }
2326     $CPAN::Frontend->mywarn(sprintf(
2327                                     "%-27s %6d\n%-27s %6d\n",
2328                                     "vm",
2329                                     $vm,
2330                                     "CPAN::META",
2331                                     Devel::Size::total_size($CPAN::META)/1024,
2332                                    ));
2333     for my $k (sort keys %$CPAN::META) {
2334         next unless substr($k,0,4) eq "read";
2335         warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
2336         for my $k2 (sort keys %{$CPAN::META->{$k}}) {
2337             warn sprintf "  %-25s %6d (keys: %6d)\n",
2338                 $k2,
2339                     Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
2340                           scalar keys %{$CPAN::META->{$k}{$k2}};
2341         }
2342     }
2343 }
2344
2345 #-> sub CPAN::Shell::autobundle ;
2346 sub autobundle {
2347     my($self) = shift;
2348     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
2349     my(@bundle) = $self->_u_r_common("a",@_);
2350     my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
2351     File::Path::mkpath($todir);
2352     unless (-d $todir) {
2353         $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
2354         return;
2355     }
2356     my($y,$m,$d) =  (localtime)[5,4,3];
2357     $y+=1900;
2358     $m++;
2359     my($c) = 0;
2360     my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
2361     my($to) = File::Spec->catfile($todir,"$me.pm");
2362     while (-f $to) {
2363         $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
2364         $to = File::Spec->catfile($todir,"$me.pm");
2365     }
2366     my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
2367     $fh->print(
2368                "package Bundle::$me;\n\n",
2369                "\$VERSION = '0.01';\n\n",
2370                "1;\n\n",
2371                "__END__\n\n",
2372                "=head1 NAME\n\n",
2373                "Bundle::$me - Snapshot of installation on ",
2374                $Config::Config{'myhostname'},
2375                " on ",
2376                scalar(localtime),
2377                "\n\n=head1 SYNOPSIS\n\n",
2378                "perl -MCPAN -e 'install Bundle::$me'\n\n",
2379                "=head1 CONTENTS\n\n",
2380                join("\n", @bundle),
2381                "\n\n=head1 CONFIGURATION\n\n",
2382                Config->myconfig,
2383                "\n\n=head1 AUTHOR\n\n",
2384                "This Bundle has been generated automatically ",
2385                "by the autobundle routine in CPAN.pm.\n",
2386               );
2387     $fh->close;
2388     $CPAN::Frontend->myprint("\nWrote bundle file
2389     $to\n\n");
2390 }
2391
2392 #-> sub CPAN::Shell::expandany ;
2393 sub expandany {
2394     my($self,$s) = @_;
2395     CPAN->debug("s[$s]") if $CPAN::DEBUG;
2396     if ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory
2397         $s = CPAN::Distribution->normalize($s);
2398         return $CPAN::META->instance('CPAN::Distribution',$s);
2399         # Distributions spring into existence, not expand
2400     } elsif ($s =~ m|^Bundle::|) {
2401         $self->local_bundles; # scanning so late for bundles seems
2402                               # both attractive and crumpy: always
2403                               # current state but easy to forget
2404                               # somewhere
2405         return $self->expand('Bundle',$s);
2406     } else {
2407         return $self->expand('Module',$s)
2408             if $CPAN::META->exists('CPAN::Module',$s);
2409     }
2410     return;
2411 }
2412
2413 #-> sub CPAN::Shell::expand ;
2414 sub expand {
2415     my $self = shift;
2416     my($type,@args) = @_;
2417     CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
2418     my $class = "CPAN::$type";
2419     my $methods = ['id'];
2420     for my $meth (qw(name)) {
2421         next unless $class->can($meth);
2422         push @$methods, $meth;
2423     }
2424     $self->expand_by_method($class,$methods,@args);
2425 }
2426
2427 #-> sub CPAN::Shell::expand_by_method ;
2428 sub expand_by_method {
2429     my $self = shift;
2430     my($class,$methods,@args) = @_;
2431     my($arg,@m);
2432     for $arg (@args) {
2433         my($regex,$command);
2434         if ($arg =~ m|^/(.*)/$|) {
2435             $regex = $1;
2436         } elsif ($arg =~ m/=/) {
2437             $command = 1;
2438         }
2439         my $obj;
2440         CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
2441                     $class,
2442                     defined $regex ? $regex : "UNDEFINED",
2443                     defined $command ? $command : "UNDEFINED",
2444                    ) if $CPAN::DEBUG;
2445         if (defined $regex) {
2446             if ($CPAN::Config->{use_sqlite} && CPAN::_init_sqlite) { # not yet officially supported
2447                 $CPAN::SQLite->search($class, $regex);
2448             }
2449             for $obj (
2450                       $CPAN::META->all_objects($class)
2451                      ) {
2452                 unless ($obj->id){
2453                     # BUG, we got an empty object somewhere
2454                     require Data::Dumper;
2455                     CPAN->debug(sprintf(
2456                                         "Bug in CPAN: Empty id on obj[%s][%s]",
2457                                         $obj,
2458                                         Data::Dumper::Dumper($obj)
2459                                        )) if $CPAN::DEBUG;
2460                     next;
2461                 }
2462                 for my $method (@$methods) {
2463                     my $match = eval {$obj->$method() =~ /$regex/i};
2464                     if ($@) {
2465                         my($err) = $@ =~ /^(.+) at .+? line \d+\.$/;
2466                         $err ||= $@; # if we were too restrictive above
2467                         $CPAN::Frontend->mydie("$err\n");
2468                     } elsif ($match) {
2469                         push @m, $obj;
2470                         last;
2471                     }
2472                 }
2473             }
2474         } elsif ($command) {
2475             die "equal sign in command disabled (immature interface), ".
2476                 "you can set
2477  ! \$CPAN::Shell::ADVANCED_QUERY=1
2478 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
2479 that may go away anytime.\n"
2480                     unless $ADVANCED_QUERY;
2481             my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
2482             my($matchcrit) = $criterion =~ m/^~(.+)/;
2483             for my $self (
2484                           sort
2485                           {$a->id cmp $b->id}
2486                           $CPAN::META->all_objects($class)
2487                          ) {
2488                 my $lhs = $self->$method() or next; # () for 5.00503
2489                 if ($matchcrit) {
2490                     push @m, $self if $lhs =~ m/$matchcrit/;
2491                 } else {
2492                     push @m, $self if $lhs eq $criterion;
2493                 }
2494             }
2495         } else {
2496             my($xarg) = $arg;
2497             if ( $class eq 'CPAN::Bundle' ) {
2498                 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
2499             } elsif ($class eq "CPAN::Distribution") {
2500                 $xarg = CPAN::Distribution->normalize($arg);
2501             } else {
2502                 $xarg =~ s/:+/::/g;
2503             }
2504             if ($CPAN::META->exists($class,$xarg)) {
2505                 $obj = $CPAN::META->instance($class,$xarg);
2506             } elsif ($CPAN::META->exists($class,$arg)) {
2507                 $obj = $CPAN::META->instance($class,$arg);
2508             } else {
2509                 next;
2510             }
2511             push @m, $obj;
2512         }
2513     }
2514     @m = sort {$a->id cmp $b->id} @m;
2515     if ( $CPAN::DEBUG ) {
2516         my $wantarray = wantarray;
2517         my $join_m = join ",", map {$_->id} @m;
2518         $self->debug("wantarray[$wantarray]join_m[$join_m]");
2519     }
2520     return wantarray ? @m : $m[0];
2521 }
2522
2523 #-> sub CPAN::Shell::format_result ;
2524 sub format_result {
2525     my($self) = shift;
2526     my($type,@args) = @_;
2527     @args = '/./' unless @args;
2528     my(@result) = $self->expand($type,@args);
2529     my $result = @result == 1 ?
2530         $result[0]->as_string :
2531             @result == 0 ?
2532                 "No objects of type $type found for argument @args\n" :
2533                     join("",
2534                          (map {$_->as_glimpse} @result),
2535                          scalar @result, " items found\n",
2536                         );
2537     $result;
2538 }
2539
2540 #-> sub CPAN::Shell::report_fh ;
2541 {
2542     my $installation_report_fh;
2543     my $previously_noticed = 0;
2544
2545     sub report_fh {
2546         return $installation_report_fh if $installation_report_fh;
2547         if ($CPAN::META->has_inst("File::Temp")) {
2548             $installation_report_fh
2549                 = File::Temp->new(
2550                                   template => 'cpan_install_XXXX',
2551                                   suffix   => '.txt',
2552                                   unlink   => 0,
2553                                  );
2554         }
2555         unless ( $installation_report_fh ) {
2556             warn("Couldn't open installation report file; " .
2557                  "no report file will be generated."
2558                 ) unless $previously_noticed++;
2559         }
2560     }
2561 }
2562
2563
2564 # The only reason for this method is currently to have a reliable
2565 # debugging utility that reveals which output is going through which
2566 # channel. No, I don't like the colors ;-)
2567
2568 # to turn colordebugging on, write
2569 # cpan> o conf colorize_output 1
2570
2571 #-> sub CPAN::Shell::print_ornamented ;
2572 {
2573     my $print_ornamented_have_warned = 0;
2574     sub colorize_output {
2575         my $colorize_output = $CPAN::Config->{colorize_output};
2576         if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
2577             unless ($print_ornamented_have_warned++) {
2578                 # no myprint/mywarn within myprint/mywarn!
2579                 warn "Colorize_output is set to true but Term::ANSIColor is not
2580 installed. To activate colorized output, please install Term::ANSIColor.\n\n";
2581             }
2582             $colorize_output = 0;
2583         }
2584         return $colorize_output;
2585     }
2586 }
2587
2588
2589 #-> sub CPAN::Shell::print_ornamented ;
2590 sub print_ornamented {
2591     my($self,$what,$ornament) = @_;
2592     return unless defined $what;
2593
2594     local $| = 1; # Flush immediately
2595     if ( $CPAN::Be_Silent ) {
2596         print {report_fh()} $what;
2597         return;
2598     }
2599     my $swhat = "$what"; # stringify if it is an object
2600     if ($CPAN::Config->{term_is_latin}){
2601         # courtesy jhi:
2602         $swhat
2603             =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
2604     }
2605     if ($self->colorize_output) {
2606         if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
2607             # if you want to have this configurable, please file a bugreport
2608             $ornament = "black on_cyan";
2609         }
2610         my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
2611         if ($@) {
2612             print "Term::ANSIColor rejects color[$ornament]: $@\n
2613 Please choose a different color (Hint: try 'o conf init color.*')\n";
2614         }
2615         print $color_on,
2616             $swhat,
2617                 Term::ANSIColor::color("reset");
2618     } else {
2619         print $swhat;
2620     }
2621 }
2622
2623 #-> sub CPAN::Shell::myprint ;
2624
2625 # where is myprint/mywarn/Frontend/etc. documented? We need guidelines
2626 # where to use what! I think, we send everything to STDOUT and use
2627 # print for normal/good news and warn for news that need more
2628 # attention. Yes, this is our working contract for now.
2629 sub myprint {
2630     my($self,$what) = @_;
2631
2632     $self->print_ornamented($what, $CPAN::Config->{colorize_print}||'bold blue on_white');
2633 }
2634
2635 #-> sub CPAN::Shell::myexit ;
2636 sub myexit {
2637     my($self,$what) = @_;
2638     $self->myprint($what);
2639     exit;
2640 }
2641
2642 #-> sub CPAN::Shell::mywarn ;
2643 sub mywarn {
2644     my($self,$what) = @_;
2645     $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
2646 }
2647
2648 # only to be used for shell commands
2649 #-> sub CPAN::Shell::mydie ;
2650 sub mydie {
2651     my($self,$what) = @_;
2652     $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
2653
2654     # If it is the shell, we want that the following die to be silent,
2655     # but if it is not the shell, we would need a 'die $what'. We need
2656     # to take care that only shell commands use mydie. Is this
2657     # possible?
2658
2659     die "\n";
2660 }
2661
2662 # sub CPAN::Shell::colorable_makemaker_prompt ;
2663 sub colorable_makemaker_prompt {
2664     my($foo,$bar) = @_;
2665     if (CPAN::Shell->colorize_output) {
2666         my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
2667         my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
2668         print $color_on;
2669     }
2670     my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
2671     if (CPAN::Shell->colorize_output) {
2672         print Term::ANSIColor::color('reset');
2673     }
2674     return $ans;
2675 }
2676
2677 # use this only for unrecoverable errors!
2678 #-> sub CPAN::Shell::unrecoverable_error ;
2679 sub unrecoverable_error {
2680     my($self,$what) = @_;
2681     my @lines = split /\n/, $what;
2682     my $longest = 0;
2683     for my $l (@lines) {
2684         $longest = length $l if length $l > $longest;
2685     }
2686     $longest = 62 if $longest > 62;
2687     for my $l (@lines) {
2688         if ($l =~ /^\s*$/){
2689             $l = "\n";
2690             next;
2691         }
2692         $l = "==> $l";
2693         if (length $l < 66) {
2694             $l = pack "A66 A*", $l, "<==";
2695         }
2696         $l .= "\n";
2697     }
2698     unshift @lines, "\n";
2699     $self->mydie(join "", @lines);
2700 }
2701
2702 #-> sub CPAN::Shell::mysleep ;
2703 sub mysleep {
2704     my($self, $sleep) = @_;
2705     sleep $sleep;
2706 }
2707
2708 #-> sub CPAN::Shell::setup_output ;
2709 sub setup_output {
2710     return if -t STDOUT;
2711     my $odef = select STDERR;
2712     $| = 1;
2713     select STDOUT;
2714     $| = 1;
2715     select $odef;
2716 }
2717
2718 #-> sub CPAN::Shell::rematein ;
2719 # RE-adme||MA-ke||TE-st||IN-stall
2720 sub rematein {
2721     my $self = shift;
2722     my($meth,@some) = @_;
2723     my @pragma;
2724     while($meth =~ /^(force|notest)$/) {
2725         push @pragma, $meth;
2726         $meth = shift @some or
2727             $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
2728                                    "cannot continue");
2729     }
2730     setup_output();
2731     CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
2732
2733     # Here is the place to set "test_count" on all involved parties to
2734     # 0. We then can pass this counter on to the involved
2735     # distributions and those can refuse to test if test_count > X. In
2736     # the first stab at it we could use a 1 for "X".
2737
2738     # But when do I reset the distributions to start with 0 again?
2739     # Jost suggested to have a random or cycling interaction ID that
2740     # we pass through. But the ID is something that is just left lying
2741     # around in addition to the counter, so I'd prefer to set the
2742     # counter to 0 now, and repeat at the end of the loop. But what
2743     # about dependencies? They appear later and are not reset, they
2744     # enter the queue but not its copy. How do they get a sensible
2745     # test_count?
2746
2747     # construct the queue
2748     my($s,@s,@qcopy);
2749   STHING: foreach $s (@some) {
2750         my $obj;
2751         if (ref $s) {
2752             CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
2753             $obj = $s;
2754         } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
2755         } elsif ($s =~ m|^/|) { # looks like a regexp
2756             if (substr($s,-1,1) eq ".") {
2757                 $obj = CPAN::Shell->expandany($s);
2758             } else {
2759                 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
2760                                         "not supported.\nRejecting argument '$s'\n");
2761                 $CPAN::Frontend->mysleep(2);
2762                 next;
2763             }
2764         } elsif ($meth eq "ls") {
2765             $self->globls($s,\@pragma);
2766             next STHING;
2767         } else {
2768             CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
2769             $obj = CPAN::Shell->expandany($s);
2770         }
2771         if (0) {
2772         } elsif (ref $obj) {
2773             $obj->color_cmd_tmps(0,1);
2774             CPAN::Queue->new(qmod => $obj->id, reqtype => "c");
2775             push @qcopy, $obj;
2776         } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
2777             $obj = $CPAN::META->instance('CPAN::Author',uc($s));
2778             if ($meth =~ /^(dump|ls)$/) {
2779                 $obj->$meth();
2780             } else {
2781                 $CPAN::Frontend->mywarn(
2782                                         join "",
2783                                         "Don't be silly, you can't $meth ",
2784                                         $obj->fullname,
2785                                         " ;-)\n"
2786                                        );
2787                 $CPAN::Frontend->mysleep(2);
2788             }
2789         } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
2790             CPAN::InfoObj->dump($s);
2791         } else {
2792             $CPAN::Frontend
2793                 ->mywarn(qq{Warning: Cannot $meth $s, }.
2794                           qq{don't know what it is.
2795 Try the command
2796
2797     i /$s/
2798
2799 to find objects with matching identifiers.
2800 });
2801             $CPAN::Frontend->mysleep(2);
2802         }
2803     }
2804
2805     # queuerunner (please be warned: when I started to change the
2806     # queue to hold objects instead of names, I made one or two
2807     # mistakes and never found which. I reverted back instead)
2808     while (my $q = CPAN::Queue->first) {
2809         my $obj;
2810         my $s = $q->as_string;
2811         my $reqtype = $q->reqtype || "";
2812         $obj = CPAN::Shell->expandany($s);
2813         $obj->{reqtype} ||= "";
2814         CPAN->debug("obj-reqtype[$obj->{reqtype}]".
2815                     "q-reqtype[$reqtype]") if $CPAN::DEBUG;
2816         if ($obj->{reqtype}) {
2817             if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
2818                 $obj->{reqtype} = $reqtype;
2819                 if (
2820                     exists $obj->{install}
2821                     &&
2822                     (
2823                      UNIVERSAL::can($obj->{install},"failed") ?
2824                      $obj->{install}->failed :
2825                      $obj->{install} =~ /^NO/
2826                     )
2827                    ) {
2828                     delete $obj->{install};
2829                     $CPAN::Frontend->mywarn
2830                         ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
2831                 }
2832             }
2833         } else {
2834             $obj->{reqtype} = $reqtype;
2835         }
2836
2837         for my $pragma (@pragma) {
2838             if ($pragma
2839                 &&
2840                 $obj->can($pragma)){
2841                 $obj->$pragma($meth);
2842             }
2843         }
2844         if ($obj->can('called_for')) {
2845             $obj->called_for($s);
2846         }
2847         CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
2848                     qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
2849
2850         push @qcopy, $obj;
2851         if ($obj->$meth()){
2852             CPAN::Queue->delete($s);
2853         } else {
2854             CPAN->debug("failed");
2855         }
2856
2857         $obj->undelay;
2858         for my $pragma (@pragma) {
2859             my $unpragma = "un$pragma";
2860             if ($obj->can($unpragma)) {
2861                 $obj->$unpragma();
2862             }
2863         }
2864         CPAN::Queue->delete_first($s);
2865     }
2866     for my $obj (@qcopy) {
2867         $obj->color_cmd_tmps(0,0);
2868     }
2869 }
2870
2871 #-> sub CPAN::Shell::recent ;
2872 sub recent {
2873   my($self) = @_;
2874
2875   CPAN::Distribution::_display_url( $self, $CPAN::Defaultrecent );
2876   return;
2877 }
2878
2879 {
2880     # set up the dispatching methods
2881     no strict "refs";
2882     for my $command (qw(
2883                         clean
2884                         cvs_import
2885                         dump
2886                         force
2887                         get
2888                         install
2889                         look
2890                         ls
2891                         make
2892                         notest
2893                         perldoc
2894                         readme
2895                         test
2896                        )) {
2897         *$command = sub { shift->rematein($command, @_); };
2898     }
2899 }
2900
2901 package CPAN::LWP::UserAgent;
2902 use strict;
2903
2904 sub config {
2905     return if $SETUPDONE;
2906     if ($CPAN::META->has_usable('LWP::UserAgent')) {
2907         require LWP::UserAgent;
2908         @ISA = qw(Exporter LWP::UserAgent);
2909         $SETUPDONE++;
2910     } else {
2911         $CPAN::Frontend->mywarn("  LWP::UserAgent not available\n");
2912     }
2913 }
2914
2915 sub get_basic_credentials {
2916     my($self, $realm, $uri, $proxy) = @_;
2917     if ($USER && $PASSWD) {
2918         return ($USER, $PASSWD);
2919     }
2920     if ( $proxy ) {
2921         ($USER,$PASSWD) = $self->get_proxy_credentials();
2922     } else {
2923         ($USER,$PASSWD) = $self->get_non_proxy_credentials();
2924     }
2925     return($USER,$PASSWD);
2926 }
2927
2928 sub get_proxy_credentials {
2929     my $self = shift;
2930     my ($user, $password);
2931     if ( defined $CPAN::Config->{proxy_user} &&
2932          defined $CPAN::Config->{proxy_pass}) {
2933         $user = $CPAN::Config->{proxy_user};
2934         $password = $CPAN::Config->{proxy_pass};
2935         return ($user, $password);
2936     }
2937     my $username_prompt = "\nProxy authentication needed!
2938  (Note: to permanently configure username and password run
2939    o conf proxy_user your_username
2940    o conf proxy_pass your_password
2941      )\nUsername:";
2942     ($user, $password) =
2943         _get_username_and_password_from_user($username_prompt);
2944     return ($user,$password);
2945 }
2946
2947 sub get_non_proxy_credentials {
2948     my $self = shift;
2949     my ($user,$password);
2950     if ( defined $CPAN::Config->{username} &&
2951          defined $CPAN::Config->{password}) {
2952         $user = $CPAN::Config->{username};
2953         $password = $CPAN::Config->{password};
2954         return ($user, $password);
2955     }
2956     my $username_prompt = "\nAuthentication needed!
2957      (Note: to permanently configure username and password run
2958        o conf username your_username
2959        o conf password your_password
2960      )\nUsername:";
2961
2962     ($user, $password) =
2963         _get_username_and_password_from_user($username_prompt);
2964     return ($user,$password);
2965 }
2966
2967 sub _get_username_and_password_from_user {
2968     my $username_message = shift;
2969     my ($username,$password);
2970
2971     ExtUtils::MakeMaker->import(qw(prompt));
2972     $username = prompt($username_message);
2973         if ($CPAN::META->has_inst("Term::ReadKey")) {
2974             Term::ReadKey::ReadMode("noecho");
2975         }
2976     else {
2977         $CPAN::Frontend->mywarn(
2978             "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"
2979         );
2980     }
2981     $password = prompt("Password:");
2982
2983         if ($CPAN::META->has_inst("Term::ReadKey")) {
2984             Term::ReadKey::ReadMode("restore");
2985         }
2986         $CPAN::Frontend->myprint("\n\n");
2987     return ($username,$password);
2988 }
2989
2990 # mirror(): Its purpose is to deal with proxy authentication. When we
2991 # call SUPER::mirror, we relly call the mirror method in
2992 # LWP::UserAgent. LWP::UserAgent will then call
2993 # $self->get_basic_credentials or some equivalent and this will be
2994 # $self->dispatched to our own get_basic_credentials method.
2995
2996 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
2997
2998 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
2999 # although we have gone through our get_basic_credentials, the proxy
3000 # server refuses to connect. This could be a case where the username or
3001 # password has changed in the meantime, so I'm trying once again without
3002 # $USER and $PASSWD to give the get_basic_credentials routine another
3003 # chance to set $USER and $PASSWD.
3004
3005 # mirror(): Its purpose is to deal with proxy authentication. When we
3006 # call SUPER::mirror, we relly call the mirror method in
3007 # LWP::UserAgent. LWP::UserAgent will then call
3008 # $self->get_basic_credentials or some equivalent and this will be
3009 # $self->dispatched to our own get_basic_credentials method.
3010
3011 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3012
3013 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3014 # although we have gone through our get_basic_credentials, the proxy
3015 # server refuses to connect. This could be a case where the username or
3016 # password has changed in the meantime, so I'm trying once again without
3017 # $USER and $PASSWD to give the get_basic_credentials routine another
3018 # chance to set $USER and $PASSWD.
3019
3020 sub mirror {
3021     my($self,$url,$aslocal) = @_;
3022     my $result = $self->SUPER::mirror($url,$aslocal);
3023     if ($result->code == 407) {
3024         undef $USER;
3025         undef $PASSWD;
3026         $result = $self->SUPER::mirror($url,$aslocal);
3027     }
3028     $result;
3029 }
3030
3031 package CPAN::FTP;
3032 use strict;
3033
3034 #-> sub CPAN::FTP::ftp_statistics
3035 # if they want to rewrite, they need to pass in a filehandle
3036 sub _ftp_statistics {
3037     my($self,$fh) = @_;
3038     my $locktype = $fh ? LOCK_EX : LOCK_SH;
3039     $fh ||= FileHandle->new;
3040     my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3041     open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!");
3042     my $sleep = 1;
3043     while (!flock $fh, $locktype|LOCK_NB) {
3044         if ($sleep>3) {
3045             $CPAN::Frontend->mywarn("Waiting for a read lock on '$file'\n");
3046         }
3047         $CPAN::Frontend->mysleep($sleep);
3048         if ($sleep <= 3) {
3049             $sleep+=0.33;
3050         }
3051     }
3052     my $stats = CPAN->_yaml_loadfile($file);
3053     if ($locktype == LOCK_SH) {
3054     } else {
3055         seek $fh, 0, 0;
3056         if (@$stats){ # no yaml no write
3057             truncate $fh, 0;
3058         }
3059     }
3060     return $stats->[0];
3061 }
3062
3063 sub _mytime () {
3064     if (CPAN->has_inst("Time::HiRes")) {
3065         return Time::HiRes::time();
3066     } else {
3067         return time;
3068     }
3069 }
3070
3071 sub _new_stats {
3072     my($self,$file) = @_;
3073     my $ret = {
3074                file => $file,
3075                attempts => [],
3076                start => _mytime,
3077               };
3078     $ret;
3079 }
3080
3081 sub _add_to_statistics {
3082     my($self,$stats) = @_;
3083     $stats->{thesiteurl} = $ThesiteURL;
3084     if (CPAN->has_inst("Time::HiRes")) {
3085         $stats->{end} = Time::HiRes::time();
3086     } else {
3087         $stats->{end} = time;
3088     }
3089     my $fh = FileHandle->new;
3090     my $fullstats = $self->_ftp_statistics($fh);
3091     push @{$fullstats->{history}}, $stats;
3092     my $time = time;
3093     shift @{$fullstats->{history}}
3094         while $time - $fullstats->{history}[0]{start} > 30*86400; # one month too much?
3095     CPAN->_yaml_dumpfile($fh,$fullstats);
3096 }
3097
3098 # if file is CHECKSUMS, suggest the place where we got the file to be
3099 # checked from, maybe only for young files?
3100 sub _recommend_url_for {
3101     my($self, $file) = @_;
3102     my $urllist = $self->_get_urllist;
3103     if ($file =~ s|/CHECKSUMS(.gz)?$||) {
3104         my $fullstats = $self->_ftp_statistics();
3105         my $history = $fullstats->{history} || [];
3106         while (my $last = pop @$history) {
3107             last if $last->{end} - time > 3600; # only young results are interesting
3108             next unless $last->{file}; # dirname of nothing dies!
3109             next unless $file eq File::Basename::dirname($last->{file});
3110             return $last->{thesiteurl};
3111         }
3112     }
3113     if ($CPAN::Config->{randomize_urllist}
3114         &&
3115         rand(1) < $CPAN::Config->{randomize_urllist}
3116        ) {
3117         $urllist->[int rand scalar @$urllist];
3118     } else {
3119         return ();
3120     }
3121 }
3122
3123 sub _get_urllist {
3124     my($self) = @_;
3125     $CPAN::Config->{urllist} ||= [];
3126     unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
3127         $CPAN::Frontend->mywarn("Malformed urllist; ignoring.  Configuration file corrupt?\n");
3128         $CPAN::Config->{urllist} = [];
3129     }
3130     my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}};
3131     for my $u (@urllist) {
3132         CPAN->debug("u[$u]") if $CPAN::DEBUG;
3133         if (UNIVERSAL::can($u,"text")) {
3134             $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
3135         } else {
3136             $u .= "/" unless substr($u,-1) eq "/";
3137             $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
3138         }
3139     }
3140     \@urllist;
3141 }
3142
3143 #-> sub CPAN::FTP::ftp_get ;
3144 sub ftp_get {
3145     my($class,$host,$dir,$file,$target) = @_;
3146     $class->debug(
3147                   qq[Going to fetch file [$file] from dir [$dir]
3148         on host [$host] as local [$target]\n]
3149                  ) if $CPAN::DEBUG;
3150     my $ftp = Net::FTP->new($host);
3151     unless ($ftp) {
3152         $CPAN::Frontend->mywarn("  Could not connect to host '$host' with Net::FTP\n");
3153         return;
3154     }
3155     return 0 unless defined $ftp;
3156     $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
3157     $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
3158     unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
3159         my $msg = $ftp->message;
3160         $CPAN::Frontend->mywarn("  Couldn't login on $host: $msg");
3161         return;
3162     }
3163     unless ( $ftp->cwd($dir) ){
3164         my $msg = $ftp->message;
3165         $CPAN::Frontend->mywarn("  Couldn't cwd $dir: $msg");
3166         return;
3167     }
3168     $ftp->binary;
3169     $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
3170     unless ( $ftp->get($file,$target) ){
3171         my $msg = $ftp->message;
3172         $CPAN::Frontend->mywarn("  Couldn't fetch $file from $host: $msg");
3173         return;
3174     }
3175     $ftp->quit; # it's ok if this fails
3176     return 1;
3177 }
3178
3179 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
3180
3181  # > *** /install/perl/live/lib/CPAN.pm-        Wed Sep 24 13:08:48 1997
3182  # > --- /tmp/cp        Wed Sep 24 13:26:40 1997
3183  # > ***************
3184  # > *** 1562,1567 ****
3185  # > --- 1562,1580 ----
3186  # >       return 1 if substr($url,0,4) eq "file";
3187  # >       return 1 unless $url =~ m|://([^/]+)|;
3188  # >       my $host = $1;
3189  # > +     my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
3190  # > +     if ($proxy) {
3191  # > +         $proxy =~ m|://([^/:]+)|;
3192  # > +         $proxy = $1;
3193  # > +         my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
3194  # > +         if ($noproxy) {
3195  # > +             if ($host !~ /$noproxy$/) {
3196  # > +                 $host = $proxy;
3197  # > +             }
3198  # > +         } else {
3199  # > +             $host = $proxy;
3200  # > +         }
3201  # > +     }
3202  # >       require Net::Ping;
3203  # >       return 1 unless $Net::Ping::VERSION >= 2;
3204  # >       my $p;
3205
3206
3207 #-> sub CPAN::FTP::localize ;
3208 sub localize {
3209     my($self,$file,$aslocal,$force) = @_;
3210     $force ||= 0;
3211     Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
3212         unless defined $aslocal;
3213     $self->debug("file[$file] aslocal[$aslocal] force[$force]")
3214         if $CPAN::DEBUG;
3215
3216     if ($^O eq 'MacOS') {
3217         # Comment by AK on 2000-09-03: Uniq short filenames would be
3218         # available in CHECKSUMS file
3219         my($name, $path) = File::Basename::fileparse($aslocal, '');
3220         if (length($name) > 31) {
3221             $name =~ s/(
3222                         \.(
3223                            readme(\.(gz|Z))? |
3224                            (tar\.)?(gz|Z) |
3225                            tgz |
3226                            zip |
3227                            pm\.(gz|Z)
3228                           )
3229                        )$//x;
3230             my $suf = $1;
3231             my $size = 31 - length($suf);
3232             while (length($name) > $size) {
3233                 chop $name;
3234             }
3235             $name .= $suf;
3236             $aslocal = File::Spec->catfile($path, $name);
3237         }
3238     }
3239
3240     if (-f $aslocal && -r _ && !($force & 1)){
3241         my $size;
3242         if ($size = -s $aslocal) {
3243             $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
3244             return $aslocal;
3245         } else {
3246             # empty file from a previous unsuccessful attempt to download it
3247             unlink $aslocal or
3248                 $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
3249                                        "could not remove.");
3250         }
3251     }
3252     my($maybe_restore) = 0;
3253     if (-f $aslocal){
3254         rename $aslocal, "$aslocal.bak$$";
3255         $maybe_restore++;
3256     }
3257
3258     my($aslocal_dir) = File::Basename::dirname($aslocal);
3259     File::Path::mkpath($aslocal_dir);
3260     $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
3261         qq{directory "$aslocal_dir".
3262     I\'ll continue, but if you encounter problems, they may be due
3263     to insufficient permissions.\n}) unless -w $aslocal_dir;
3264
3265     # Inheritance is not easier to manage than a few if/else branches
3266     if ($CPAN::META->has_usable('LWP::UserAgent')) {
3267         unless ($Ua) {
3268             CPAN::LWP::UserAgent->config;
3269             eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
3270             if ($@) {
3271                 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
3272                     if $CPAN::DEBUG;
3273             } else {
3274                 my($var);
3275                 $Ua->proxy('ftp',  $var)
3276                     if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
3277                 $Ua->proxy('http', $var)
3278                     if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
3279
3280
3281 # >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
3282 #
3283 #  > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
3284 #  > use ones that require basic autorization.
3285 #
3286 #  > Example of when I use it manually in my own stuff:
3287 #
3288 #  > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
3289 #  > $req->proxy_authorization_basic("username","password");
3290 #  > $res = $ua->request($req);
3291 #
3292
3293                 $Ua->no_proxy($var)
3294                     if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
3295             }
3296         }
3297     }
3298     for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
3299         $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
3300     }
3301
3302     # Try the list of urls for each single object. We keep a record
3303     # where we did get a file from
3304     my(@reordered,$last);
3305     my $ccurllist = $self->_get_urllist;
3306     $last = $#$ccurllist;
3307     if ($force & 2) { # local cpans probably out of date, don't reorder
3308         @reordered = (0..$last);
3309     } else {
3310         @reordered =
3311             sort {
3312                 (substr($ccurllist->[$b],0,4) eq "file")
3313                     <=>
3314                 (substr($ccurllist->[$a],0,4) eq "file")
3315                     or
3316                 defined($ThesiteURL)
3317                     and
3318                 ($ccurllist->[$b] eq $ThesiteURL)
3319                     <=>
3320                 ($ccurllist->[$a] eq $ThesiteURL)
3321             } 0..$last;
3322     }
3323     my(@levels);
3324     $Themethod ||= "";
3325     $self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG;
3326     if ($Themethod) {
3327         @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
3328     } else {
3329         @levels = qw/easy hard hardest/;
3330     }
3331     @levels = qw/easy/ if $^O eq 'MacOS';
3332     my($levelno);
3333     local $ENV{FTP_PASSIVE} =
3334         exists $CPAN::Config->{ftp_passive} ?
3335         $CPAN::Config->{ftp_passive} : 1;
3336     my $ret;
3337     my $stats = $self->_new_stats($file);
3338   LEVEL: for $levelno (0..$#levels) {
3339         my $level = $levels[$levelno];
3340         my $method = "host$level";
3341         my @host_seq = $level eq "easy" ?
3342             @reordered : 0..$last;  # reordered has CDROM up front
3343         my @urllist = map { $ccurllist->[$_] } @host_seq;
3344         for my $u (@CPAN::Defaultsites) {
3345             push @urllist, $u unless grep { $_ eq $u } @urllist;
3346         }
3347         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
3348         my $aslocal_tempfile = $aslocal . ".tmp" . $$;
3349         if (my $recommend = $self->_recommend_url_for($file)) {
3350             @urllist = grep { $_ ne $recommend } @urllist;
3351             unshift @urllist, $recommend;
3352         }
3353         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
3354         $ret = $self->$method(\@urllist,$file,$aslocal_tempfile,$stats);
3355         if ($ret) {
3356             CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG;
3357             if ($ret eq $aslocal_tempfile) {
3358                 # if we got it exactly as we asked for, only then we
3359                 # want to rename
3360                 rename $aslocal_tempfile, $aslocal
3361                     or $CPAN::Frontend->mydie("Error while trying to rename ".
3362                                               "'$ret' to '$aslocal': $!");
3363                 $ret = $aslocal;
3364             }
3365             $Themethod = $level;
3366             my $now = time;
3367             # utime $now, $now, $aslocal; # too bad, if we do that, we
3368                                           # might alter a local mirror
3369             $self->debug("level[$level]") if $CPAN::DEBUG;
3370             last LEVEL;
3371         } else {
3372             unlink $aslocal_tempfile;
3373             last if $CPAN::Signal; # need to cleanup
3374         }
3375     }
3376     if ($ret) {
3377         $stats->{filesize} = -s $ret;
3378     }
3379     $self->_add_to_statistics($stats);
3380     if ($ret) {
3381         unlink "$aslocal.bak$$";
3382         return $ret;
3383     }
3384     unless ($CPAN::Signal) {
3385         my(@mess);
3386         local $" = " ";
3387         if (@{$CPAN::Config->{urllist}}) {
3388             push @mess,
3389                 qq{Please check, if the URLs I found in your configuration file \(}.
3390                     join(", ", @{$CPAN::Config->{urllist}}).
3391                         qq{\) are valid.};
3392         } else {
3393             push @mess, qq{Your urllist is empty!};
3394         }
3395         push @mess, qq{The urllist can be edited.},
3396             qq{E.g. with 'o conf urllist push ftp://myurl/'};
3397         $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
3398         $CPAN::Frontend->mywarn("Could not fetch $file\n");
3399         $CPAN::Frontend->mysleep(2);
3400     }
3401     if ($maybe_restore) {
3402         rename "$aslocal.bak$$", $aslocal;
3403         $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
3404                                  $self->ls($aslocal));
3405         return $aslocal;
3406     }
3407     return;
3408 }
3409
3410 sub _set_attempt {
3411     my($self,$stats,$method,$url) = @_;
3412     push @{$stats->{attempts}}, {
3413                                  method => $method,
3414                                  start => _mytime,
3415                                  url => $url,
3416                                 };
3417 }
3418
3419 # package CPAN::FTP;
3420 sub hosteasy {
3421     my($self,$host_seq,$file,$aslocal,$stats) = @_;
3422     my($ro_url);
3423   HOSTEASY: for $ro_url (@$host_seq) {
3424         $self->_set_attempt($stats,"easy",$ro_url);
3425         my $url .= "$ro_url$file";
3426         $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
3427         if ($url =~ /^file:/) {
3428             my $l;
3429             if ($CPAN::META->has_inst('URI::URL')) {
3430                 my $u =  URI::URL->new($url);
3431                 $l = $u->path;
3432             } else { # works only on Unix, is poorly constructed, but
3433                 # hopefully better than nothing.
3434                 # RFC 1738 says fileurl BNF is
3435                 # fileurl = "file://" [ host | "localhost" ] "/" fpath
3436                 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
3437                 # the code
3438                 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
3439                 $l =~ s|^file:||;                   # assume they
3440                                                     # meant
3441                                                     # file://localhost
3442                 $l =~ s|^/||s
3443                     if ! -f $l && $l =~ m|^/\w:|;   # e.g. /P:
3444             }
3445             $self->debug("local file[$l]") if $CPAN::DEBUG;
3446             if ( -f $l && -r _) {
3447                 $ThesiteURL = $ro_url;
3448                 return $l;
3449             }
3450             if ($l =~ /(.+)\.gz$/) {
3451                 my $ungz = $1;
3452                 if ( -f $ungz && -r _) {
3453                     $ThesiteURL = $ro_url;
3454                     return $ungz;
3455                 }
3456             }
3457             # Maybe mirror has compressed it?
3458             if (-f "$l.gz") {
3459                 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
3460                 eval { CPAN::Tarzip->new("$l.gz")->gunzip($aslocal) };
3461                 if ( -f $aslocal) {
3462                     $ThesiteURL = $ro_url;
3463                     return $aslocal;
3464                 }
3465             }
3466         }
3467         $self->debug("it was not a file URL") if $CPAN::DEBUG;
3468         if ($CPAN::META->has_usable('LWP')) {
3469             $CPAN::Frontend->myprint("Fetching with LWP:
3470   $url
3471 ");
3472             unless ($Ua) {
3473                 CPAN::LWP::UserAgent->config;
3474                 eval { $Ua = CPAN::LWP::UserAgent->new; };
3475                 if ($@) {
3476                     $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
3477                 }
3478             }
3479             my $res = $Ua->mirror($url, $aslocal);
3480             if ($res->is_success) {
3481                 $ThesiteURL = $ro_url;
3482                 my $now = time;
3483                 utime $now, $now, $aslocal; # download time is more
3484                                             # important than upload
3485                                             # time
3486                 return $aslocal;
3487             } elsif ($url !~ /\.gz(?!\n)\Z/) {
3488                 my $gzurl = "$url.gz";
3489                 $CPAN::Frontend->myprint("Fetching with LWP:
3490   $gzurl
3491 ");
3492                 $res = $Ua->mirror($gzurl, "$aslocal.gz");
3493                 if ($res->is_success) {
3494                     if (eval {CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)}) {
3495                         $ThesiteURL = $ro_url;
3496                         return $aslocal;
3497                     }
3498                 }
3499             } else {
3500                 $CPAN::Frontend->myprint(sprintf(
3501                                                  "LWP failed with code[%s] message[%s]\n",
3502                                                  $res->code,
3503                                                  $res->message,
3504                                                 ));
3505                 # Alan Burlison informed me that in firewall environments
3506                 # Net::FTP can still succeed where LWP fails. So we do not
3507                 # skip Net::FTP anymore when LWP is available.
3508             }
3509         } else {
3510             $CPAN::Frontend->mywarn("  LWP not available\n");
3511         }
3512         return if $CPAN::Signal;
3513         if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3514             # that's the nice and easy way thanks to Graham
3515             $self->debug("recognized ftp") if $CPAN::DEBUG;
3516             my($host,$dir,$getfile) = ($1,$2,$3);
3517             if ($CPAN::META->has_usable('Net::FTP')) {
3518                 $dir =~ s|/+|/|g;
3519                 $CPAN::Frontend->myprint("Fetching with Net::FTP:
3520   $url
3521 ");
3522                 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
3523                              "aslocal[$aslocal]") if $CPAN::DEBUG;
3524                 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
3525                     $ThesiteURL = $ro_url;
3526                     return $aslocal;
3527                 }
3528                 if ($aslocal !~ /\.gz(?!\n)\Z/) {
3529                     my $gz = "$aslocal.gz";
3530                     $CPAN::Frontend->myprint("Fetching with Net::FTP
3531   $url.gz
3532 ");
3533                     if (CPAN::FTP->ftp_get($host,
3534                                            $dir,
3535                                            "$getfile.gz",
3536                                            $gz) &&
3537                         eval{CPAN::Tarzip->new($gz)->gunzip($aslocal)}
3538                        ){
3539                         $ThesiteURL = $ro_url;
3540                         return $aslocal;
3541                     }
3542                 }
3543                 # next HOSTEASY;
3544             } else {
3545                 CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG;
3546             }
3547         }
3548         if (
3549             UNIVERSAL::can($ro_url,"text")
3550             and
3551             $ro_url->{FROM} eq "USER"
3552            ){
3553             ##address #17973: default URLs should not try to override
3554             ##user-defined URLs just because LWP is not available
3555             my $ret = $self->hosthard([$ro_url],$file,$aslocal,$stats);
3556             return $ret if $ret;
3557         }
3558         return if $CPAN::Signal;
3559     }
3560 }
3561
3562 # package CPAN::FTP;
3563 sub hosthard {
3564   my($self,$host_seq,$file,$aslocal,$stats) = @_;
3565
3566   # Came back if Net::FTP couldn't establish connection (or
3567   # failed otherwise) Maybe they are behind a firewall, but they
3568   # gave us a socksified (or other) ftp program...
3569
3570   my($ro_url);
3571   my($devnull) = $CPAN::Config->{devnull} || "";
3572   # < /dev/null ";
3573   my($aslocal_dir) = File::Basename::dirname($aslocal);
3574   File::Path::mkpath($aslocal_dir);
3575   HOSTHARD: for $ro_url (@$host_seq) {
3576         $self->_set_attempt($stats,"hard",$ro_url);
3577         my $url = "$ro_url$file";
3578         my($proto,$host,$dir,$getfile);
3579
3580         # Courtesy Mark Conty mark_conty@cargill.com change from
3581         # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3582         # to
3583         if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
3584           # proto not yet used
3585           ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
3586         } else {
3587           next HOSTHARD; # who said, we could ftp anything except ftp?
3588         }
3589         next HOSTHARD if $proto eq "file"; # file URLs would have had
3590                                            # success above. Likely a bogus URL
3591
3592         $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
3593
3594         # Try the most capable first and leave ncftp* for last as it only
3595         # does FTP.
3596       DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
3597           my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
3598           next unless defined $funkyftp;
3599           next if $funkyftp =~ /^\s*$/;
3600
3601           my($asl_ungz, $asl_gz);
3602           ($asl_ungz = $aslocal) =~ s/\.gz//;
3603           $asl_gz = "$asl_ungz.gz";
3604
3605           my($src_switch) = "";
3606           my($chdir) = "";
3607           my($stdout_redir) = " > $asl_ungz";
3608           if ($f eq "lynx"){
3609             $src_switch = " -source";
3610           } elsif ($f eq "ncftp"){
3611             $src_switch = " -c";
3612           } elsif ($f eq "wget"){
3613             $src_switch = " -O $asl_ungz";
3614             $stdout_redir = "";
3615           } elsif ($f eq 'curl'){
3616             $src_switch = ' -L -f -s -S --netrc-optional';
3617           }
3618
3619           if ($f eq "ncftpget"){
3620             $chdir = "cd $aslocal_dir && ";
3621             $stdout_redir = "";
3622           }
3623           $CPAN::Frontend->myprint(
3624                                    qq[
3625 Trying with "$funkyftp$src_switch" to get
3626     $url
3627 ]);
3628           my($system) =
3629               "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
3630           $self->debug("system[$system]") if $CPAN::DEBUG;
3631           my($wstatus) = system($system);
3632           if ($f eq "lynx") {
3633               # lynx returns 0 when it fails somewhere
3634               if (-s $asl_ungz) {
3635                   my $content = do { local *FH;
3636                                      open FH, $asl_ungz or die;
3637                                      local $/;
3638                                      <FH> };
3639                   if ($content =~ /^<.*(<title>[45]|Error [45])/si) {
3640                       $CPAN::Frontend->mywarn(qq{
3641 No success, the file that lynx has has downloaded looks like an error message:
3642 $content
3643 });
3644                       $CPAN::Frontend->mysleep(1);
3645                       next DLPRG;
3646                   }
3647               } else {
3648                   $CPAN::Frontend->myprint(qq{
3649 No success, the file that lynx has has downloaded is an empty file.
3650 });
3651                   next DLPRG;
3652               }
3653           }
3654           if ($wstatus == 0) {
3655             if (-s $aslocal) {
3656               # Looks good
3657             } elsif ($asl_ungz ne $aslocal) {
3658               # test gzip integrity
3659               if (eval{CPAN::Tarzip->new($asl_ungz)->gtest}) {
3660                   # e.g. foo.tar is gzipped --> foo.tar.gz
3661                   rename $asl_ungz, $aslocal;
3662               } else {
3663                   eval{CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz)};
3664               }
3665             }
3666             $ThesiteURL = $ro_url;
3667             return $aslocal;
3668           } elsif ($url !~ /\.gz(?!\n)\Z/) {
3669             unlink $asl_ungz if
3670                 -f $asl_ungz && -s _ == 0;
3671             my $gz = "$aslocal.gz";
3672             my $gzurl = "$url.gz";
3673             $CPAN::Frontend->myprint(
3674                                      qq[
3675 Trying with "$funkyftp$src_switch" to get
3676   $url.gz
3677 ]);
3678             my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
3679             $self->debug("system[$system]") if $CPAN::DEBUG;
3680             my($wstatus);
3681             if (($wstatus = system($system)) == 0
3682                 &&
3683                 -s $asl_gz
3684                ) {
3685               # test gzip integrity
3686                 my $ct = eval{CPAN::Tarzip->new($asl_gz)};
3687                 if ($ct && $ct->gtest) {
3688                     $ct->gunzip($aslocal);
3689                 } else {
3690                     # somebody uncompressed file for us?
3691                     rename $asl_ungz, $aslocal;
3692                 }
3693                 $ThesiteURL = $ro_url;
3694                 return $aslocal;
3695             } else {
3696               unlink $asl_gz if -f $asl_gz;
3697             }
3698           } else {
3699             my $estatus = $wstatus >> 8;
3700             my $size = -f $aslocal ?
3701                 ", left\n$aslocal with size ".-s _ :
3702                     "\nWarning: expected file [$aslocal] doesn't exist";
3703             $CPAN::Frontend->myprint(qq{
3704 System call "$system"
3705 returned status $estatus (wstat $wstatus)$size
3706 });
3707           }
3708           return if $CPAN::Signal;
3709         } # transfer programs
3710     } # host
3711 }
3712
3713 # package CPAN::FTP;
3714 sub hosthardest {
3715     my($self,$host_seq,$file,$aslocal,$stats) = @_;
3716
3717     my($ro_url);
3718     my($aslocal_dir) = File::Basename::dirname($aslocal);
3719     File::Path::mkpath($aslocal_dir);
3720     my $ftpbin = $CPAN::Config->{ftp};
3721     unless ($ftpbin && length $ftpbin && MM->maybe_command($ftpbin)) {
3722         $CPAN::Frontend->myprint("No external ftp command available\n\n");
3723         return;
3724     }
3725     $CPAN::Frontend->mywarn(qq{
3726 As a last ressort we now switch to the external ftp command '$ftpbin'
3727 to get '$aslocal'.
3728
3729 Doing so often leads to problems that are hard to diagnose.
3730
3731 If you're victim of such problems, please consider unsetting the ftp
3732 config variable with
3733
3734     o conf ftp ""
3735     o conf commit
3736
3737 });
3738     $CPAN::Frontend->mysleep(2);
3739   HOSTHARDEST: for $ro_url (@$host_seq) {
3740         $self->_set_attempt($stats,"hardest",$ro_url);
3741         my $url = "$ro_url$file";
3742         $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
3743         unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3744             next;
3745         }
3746         my($host,$dir,$getfile) = ($1,$2,$3);
3747         my $timestamp = 0;
3748         my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
3749            $ctime,$blksize,$blocks) = stat($aslocal);
3750         $timestamp = $mtime ||= 0;
3751         my($netrc) = CPAN::FTP::netrc->new;
3752         my($netrcfile) = $netrc->netrc;
3753         my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
3754         my $targetfile = File::Basename::basename($aslocal);
3755         my(@dialog);
3756         push(
3757              @dialog,
3758              "lcd $aslocal_dir",
3759              "cd /",
3760              map("cd $_", split /\//, $dir), # RFC 1738
3761              "bin",
3762              "get $getfile $targetfile",
3763              "quit"
3764             );
3765         if (! $netrcfile) {
3766             CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
3767         } elsif ($netrc->hasdefault || $netrc->contains($host)) {
3768             CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
3769                                 $netrc->hasdefault,
3770                                 $netrc->contains($host))) if $CPAN::DEBUG;
3771             if ($netrc->protected) {
3772                 my $dialog = join "", map { "    $_\n" } @dialog;
3773                 my $netrc_explain;
3774                 if ($netrc->contains($host)) {
3775                     $netrc_explain = "Relying that your .netrc entry for '$host' ".
3776                         "manages the login";
3777                 } else {
3778                     $netrc_explain = "Relying that your default .netrc entry ".
3779                         "manages the login";
3780                 }
3781                 $CPAN::Frontend->myprint(qq{
3782   Trying with external ftp to get
3783     $url
3784   $netrc_explain
3785   Going to send the dialog
3786 $dialog
3787 }
3788                      );
3789                 $self->talk_ftp("$ftpbin$verbose $host",
3790                                 @dialog);
3791                 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
3792                  $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
3793                 $mtime ||= 0;
3794                 if ($mtime > $timestamp) {
3795                     $CPAN::Frontend->myprint("GOT $aslocal\n");
3796                     $ThesiteURL = $ro_url;
3797                     return $aslocal;
3798                 } else {
3799                     $CPAN::Frontend->myprint("Hmm... Still failed!\n");
3800                 }
3801                 return if $CPAN::Signal;
3802             } else {
3803                 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
3804                                         qq{correctly protected.\n});
3805             }
3806         } else {
3807             $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
3808   nor does it have a default entry\n");
3809         }
3810
3811         # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
3812         # then and login manually to host, using e-mail as
3813         # password.
3814         $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
3815         unshift(
3816                 @dialog,
3817                 "open $host",
3818                 "user anonymous $Config::Config{'cf_email'}"
3819                );
3820         my $dialog = join "", map { "    $_\n" } @dialog;
3821         $CPAN::Frontend->myprint(qq{
3822   Trying with external ftp to get
3823     $url
3824   Going to send the dialog
3825 $dialog
3826 }
3827                      );
3828         $self->talk_ftp("$ftpbin$verbose -n", @dialog);
3829         ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
3830          $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
3831         $mtime ||= 0;
3832         if ($mtime > $timestamp) {
3833             $CPAN::Frontend->myprint("GOT $aslocal\n");
3834             $ThesiteURL = $ro_url;
3835             return $aslocal;
3836         } else {
3837             $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
3838         }
3839         return if $CPAN::Signal;
3840         $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
3841         $CPAN::Frontend->mysleep(2);
3842     } # host
3843 }
3844
3845 # package CPAN::FTP;
3846 sub talk_ftp {
3847     my($self,$command,@dialog) = @_;
3848     my $fh = FileHandle->new;
3849     $fh->open("|$command") or die "Couldn't open ftp: $!";
3850     foreach (@dialog) { $fh->print("$_\n") }
3851     $fh->close;         # Wait for process to complete
3852     my $wstatus = $?;
3853     my $estatus = $wstatus >> 8;
3854     $CPAN::Frontend->myprint(qq{
3855 Subprocess "|$command"
3856   returned status $estatus (wstat $wstatus)
3857 }) if $wstatus;
3858 }
3859
3860 # find2perl needs modularization, too, all the following is stolen
3861 # from there
3862 # CPAN::FTP::ls
3863 sub ls {
3864     my($self,$name) = @_;
3865     my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
3866      $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
3867
3868     my($perms,%user,%group);
3869     my $pname = $name;
3870
3871     if ($blocks) {
3872         $blocks = int(($blocks + 1) / 2);
3873     }
3874     else {
3875         $blocks = int(($sizemm + 1023) / 1024);
3876     }
3877
3878     if    (-f _) { $perms = '-'; }
3879     elsif (-d _) { $perms = 'd'; }
3880     elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
3881     elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
3882     elsif (-p _) { $perms = 'p'; }
3883     elsif (-S _) { $perms = 's'; }
3884     else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
3885
3886     my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
3887     my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
3888     my $tmpmode = $mode;
3889     my $tmp = $rwx[$tmpmode & 7];
3890     $tmpmode >>= 3;
3891     $tmp = $rwx[$tmpmode & 7] . $tmp;
3892     $tmpmode >>= 3;
3893     $tmp = $rwx[$tmpmode & 7] . $tmp;
3894     substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
3895     substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
3896     substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
3897     $perms .= $tmp;
3898
3899     my $user = $user{$uid} || $uid;   # too lazy to implement lookup
3900     my $group = $group{$gid} || $gid;
3901
3902     my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
3903     my($timeyear);
3904     my($moname) = $moname[$mon];
3905     if (-M _ > 365.25 / 2) {
3906         $timeyear = $year + 1900;
3907     }
3908     else {
3909         $timeyear = sprintf("%02d:%02d", $hour, $min);
3910     }
3911
3912     sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
3913             $ino,
3914                  $blocks,
3915                       $perms,
3916                             $nlink,
3917                                 $user,
3918                                      $group,
3919                                           $sizemm,
3920                                               $moname,
3921                                                  $mday,
3922                                                      $timeyear,
3923                                                          $pname;
3924 }
3925
3926 package CPAN::FTP::netrc;
3927 use strict;
3928
3929 # package CPAN::FTP::netrc;
3930 sub new {
3931     my($class) = @_;
3932     my $home = CPAN::HandleConfig::home;
3933     my $file = File::Spec->catfile($home,".netrc");
3934
3935     my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
3936        $atime,$mtime,$ctime,$blksize,$blocks)
3937         = stat($file);
3938     $mode ||= 0;
3939     my $protected = 0;
3940
3941     my($fh,@machines,$hasdefault);
3942     $hasdefault = 0;
3943     $fh = FileHandle->new or die "Could not create a filehandle";
3944
3945     if($fh->open($file)){
3946         $protected = ($mode & 077) == 0;
3947         local($/) = "";
3948       NETRC: while (<$fh>) {
3949             my(@tokens) = split " ", $_;
3950           TOKEN: while (@tokens) {
3951                 my($t) = shift @tokens;
3952                 if ($t eq "default"){
3953                     $hasdefault++;
3954                     last NETRC;
3955                 }
3956                 last TOKEN if $t eq "macdef";
3957                 if ($t eq "machine") {
3958                     push @machines, shift @tokens;
3959                 }
3960             }
3961         }
3962     } else {
3963         $file = $hasdefault = $protected = "";
3964     }
3965
3966     bless {
3967            'mach' => [@machines],
3968            'netrc' => $file,
3969            'hasdefault' => $hasdefault,
3970            'protected' => $protected,
3971           }, $class;
3972 }
3973
3974 # CPAN::FTP::netrc::hasdefault;
3975 sub hasdefault { shift->{'hasdefault'} }
3976 sub netrc      { shift->{'netrc'}      }
3977 sub protected  { shift->{'protected'}  }
3978 sub contains {
3979     my($self,$mach) = @_;
3980     for ( @{$self->{'mach'}} ) {
3981         return 1 if $_ eq $mach;
3982     }
3983     return 0;
3984 }
3985
3986 package CPAN::Complete;
3987 use strict;
3988
3989 sub gnu_cpl {
3990     my($text, $line, $start, $end) = @_;
3991     my(@perlret) = cpl($text, $line, $start);
3992     # find longest common match. Can anybody show me how to peruse
3993     # T::R::Gnu to have this done automatically? Seems expensive.
3994     return () unless @perlret;
3995     my($newtext) = $text;
3996     for (my $i = length($text)+1;;$i++) {
3997         last unless length($perlret[0]) && length($perlret[0]) >= $i;
3998         my $try = substr($perlret[0],0,$i);
3999         my @tries = grep {substr($_,0,$i) eq $try} @perlret;
4000         # warn "try[$try]tries[@tries]";
4001         if (@tries == @perlret) {
4002             $newtext = $try;
4003         } else {
4004             last;
4005         }
4006     }
4007     ($newtext,@perlret);
4008 }
4009
4010 #-> sub CPAN::Complete::cpl ;
4011 sub cpl {
4012     my($word,$line,$pos) = @_;
4013     $word ||= "";
4014     $line ||= "";
4015     $pos ||= 0;
4016     CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4017     $line =~ s/^\s*//;
4018     if ($line =~ s/^(force\s*)//) {
4019         $pos -= length($1);
4020     }
4021     my @return;
4022     if ($pos == 0) {
4023         @return = grep /^$word/, @CPAN::Complete::COMMANDS;
4024     } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
4025         @return = ();
4026     } elsif ($line =~ /^(a|ls)\s/) {
4027         @return = cplx('CPAN::Author',uc($word));
4028     } elsif ($line =~ /^b\s/) {
4029         CPAN::Shell->local_bundles;
4030         @return = cplx('CPAN::Bundle',$word);
4031     } elsif ($line =~ /^d\s/) {
4032         @return = cplx('CPAN::Distribution',$word);
4033     } elsif ($line =~ m/^(
4034                           [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
4035                          )\s/x ) {
4036         if ($word =~ /^Bundle::/) {
4037             CPAN::Shell->local_bundles;
4038         }
4039         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
4040     } elsif ($line =~ /^i\s/) {
4041         @return = cpl_any($word);
4042     } elsif ($line =~ /^reload\s/) {
4043         @return = cpl_reload($word,$line,$pos);
4044     } elsif ($line =~ /^o\s/) {
4045         @return = cpl_option($word,$line,$pos);
4046     } elsif ($line =~ m/^\S+\s/ ) {
4047         # fallback for future commands and what we have forgotten above
4048         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
4049     } else {
4050         @return = ();
4051     }
4052     return @return;
4053 }
4054
4055 #-> sub CPAN::Complete::cplx ;
4056 sub cplx {
4057     my($class, $word) = @_;
4058     # I believed for many years that this was sorted, today I
4059     # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
4060     # make it sorted again. Maybe sort was dropped when GNU-readline
4061     # support came in? The RCS file is difficult to read on that:-(
4062     sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
4063 }
4064
4065 #-> sub CPAN::Complete::cpl_any ;
4066 sub cpl_any {
4067     my($word) = shift;
4068     return (
4069             cplx('CPAN::Author',$word),
4070             cplx('CPAN::Bundle',$word),
4071             cplx('CPAN::Distribution',$word),
4072             cplx('CPAN::Module',$word),
4073            );
4074 }
4075
4076 #-> sub CPAN::Complete::cpl_reload ;
4077 sub cpl_reload {
4078     my($word,$line,$pos) = @_;
4079     $word ||= "";
4080     my(@words) = split " ", $line;
4081     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4082     my(@ok) = qw(cpan index);
4083     return @ok if @words == 1;
4084     return grep /^\Q$word\E/, @ok if @words == 2 && $word;
4085 }
4086
4087 #-> sub CPAN::Complete::cpl_option ;
4088 sub cpl_option {
4089     my($word,$line,$pos) = @_;
4090     $word ||= "";
4091     my(@words) = split " ", $line;
4092     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4093     my(@ok) = qw(conf debug);
4094     return @ok if @words == 1;
4095     return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
4096     if (0) {
4097     } elsif ($words[1] eq 'index') {
4098         return ();
4099     } elsif ($words[1] eq 'conf') {
4100         return CPAN::HandleConfig::cpl(@_);
4101     } elsif ($words[1] eq 'debug') {
4102         return sort grep /^\Q$word\E/i,
4103             sort keys %CPAN::DEBUG, 'all';
4104     }
4105 }
4106
4107 package CPAN::Index;
4108 use strict;
4109
4110 #-> sub CPAN::Index::force_reload ;
4111 sub force_reload {
4112     my($class) = @_;
4113     $CPAN::Index::LAST_TIME = 0;
4114     $class->reload(1);
4115 }
4116
4117 #-> sub CPAN::Index::reload ;
4118 sub reload {
4119     my($self,$force) = @_;
4120     my $time = time;
4121
4122     # XXX check if a newer one is available. (We currently read it
4123     # from time to time)
4124     for ($CPAN::Config->{index_expire}) {
4125         $_ = 0.001 unless $_ && $_ > 0.001;
4126     }
4127     unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
4128         # debug here when CPAN doesn't seem to read the Metadata
4129         require Carp;
4130         Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
4131     }
4132     unless ($CPAN::META->{PROTOCOL}) {
4133         $self->read_metadata_cache;
4134         $CPAN::META->{PROTOCOL} ||= "1.0";
4135     }
4136     if ( $CPAN::META->{PROTOCOL} < PROTOCOL  ) {
4137         # warn "Setting last_time to 0";
4138         $LAST_TIME = 0; # No warning necessary
4139     }
4140     if ($LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
4141         and ! $force){
4142         # called too often
4143         # CPAN->debug("LAST_TIME[$LAST_TIME]index_expire[$CPAN::Config->{index_expire}]time[$time]");
4144     } elsif (0) {
4145         # IFF we are developing, it helps to wipe out the memory
4146         # between reloads, otherwise it is not what a user expects.
4147         undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
4148         $CPAN::META = CPAN->new;
4149     } else {
4150         my($debug,$t2);
4151         local $LAST_TIME = $time;
4152         local $CPAN::META->{PROTOCOL} = PROTOCOL;
4153
4154         my $needshort = $^O eq "dos";
4155
4156         $self->rd_authindex($self
4157                           ->reload_x(
4158                                      "authors/01mailrc.txt.gz",
4159                                      $needshort ?
4160                                      File::Spec->catfile('authors', '01mailrc.gz') :
4161                                      File::Spec->catfile('authors', '01mailrc.txt.gz'),
4162                                      $force));
4163         $t2 = time;
4164         $debug = "timing reading 01[".($t2 - $time)."]";
4165         $time = $t2;
4166         return if $CPAN::Signal; # this is sometimes lengthy
4167         $self->rd_modpacks($self
4168                          ->reload_x(
4169                                     "modules/02packages.details.txt.gz",
4170                                     $needshort ?
4171                                     File::Spec->catfile('modules', '02packag.gz') :
4172                                     File::Spec->catfile('modules', '02packages.details.txt.gz'),
4173                                     $force));
4174         $t2 = time;
4175         $debug .= "02[".($t2 - $time)."]";
4176         $time = $t2;
4177         return if $CPAN::Signal; # this is sometimes lengthy
4178         $self->rd_modlist($self
4179                         ->reload_x(
4180                                    "modules/03modlist.data.gz",
4181                                    $needshort ?
4182                                    File::Spec->catfile('modules', '03mlist.gz') :
4183                                    File::Spec->catfile('modules', '03modlist.data.gz'),
4184                                    $force));
4185         $self->write_metadata_cache;
4186         $t2 = time;
4187         $debug .= "03[".($t2 - $time)."]";
4188         $time = $t2;
4189         CPAN->debug($debug) if $CPAN::DEBUG;
4190     }
4191     if ($CPAN::Config->{build_dir_reuse}) {
4192         $self->reanimate_build_dir;
4193     }
4194     if ($CPAN::Config->{use_sqlite} && CPAN::_init_sqlite) { # not yet officially supported
4195         $CPAN::SQLite->reload(time => $time, force => $force)
4196             if not $LAST_TIME;
4197     }
4198     $LAST_TIME = $time;
4199     $CPAN::META->{PROTOCOL} = PROTOCOL;
4200 }
4201
4202 #-> sub CPAN::Index::reanimate_build_dir ;
4203 sub reanimate_build_dir {
4204     my($self) = @_;
4205     unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module}||"YAML")) {
4206         return;
4207     }
4208     return if $HAVE_REANIMATED++;
4209     my $d = $CPAN::Config->{build_dir};
4210     my $dh = DirHandle->new;
4211     opendir $dh, $d or return; # does not exist
4212     my $dirent;
4213     my $i = 0;
4214     my $painted = 0;
4215     my $restored = 0;
4216     $CPAN::Frontend->myprint("Going to read $CPAN::Config->{build_dir}/\n");
4217     my @candidates = map { $_->[0] }
4218         sort { $b->[1] <=> $a->[1] }
4219             map { [ $_, -M File::Spec->catfile($d,$_) ] }
4220                 grep {/\.yml$/} readdir $dh;
4221   DISTRO: for $dirent (@candidates) {
4222         my $c = CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))->[0];
4223         if ($c && CPAN->_perl_fingerprint($c->{perl})) {
4224             my $key = $c->{distribution}{ID};
4225             for my $k (keys %{$c->{distribution}}) {
4226                 if ($c->{distribution}{$k}
4227                     && ref $c->{distribution}{$k}
4228                     && UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) {
4229                     $c->{distribution}{$k}{COMMANDID} = $i - @candidates;
4230                 }
4231             }
4232
4233             #we tried to restore only if element already
4234             #exists; but then we do not work with metadata
4235             #turned off.
4236             $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key} = $c->{distribution};
4237             $restored++;
4238         }
4239         $i++;
4240         while (($painted/76) < ($i/@candidates)) {
4241             $CPAN::Frontend->myprint(".");
4242             $painted++;
4243         }
4244     }
4245     $CPAN::Frontend->myprint(sprintf(
4246                                      "DONE\nFound %s old builds, restored the state of %s\n",
4247                                      @candidates ? sprintf("%d",scalar @candidates) : "no",
4248                                      $restored || "none",
4249                                     ));
4250 }
4251
4252
4253 #-> sub CPAN::Index::reload_x ;
4254 sub reload_x {
4255     my($cl,$wanted,$localname,$force) = @_;
4256     $force |= 2; # means we're dealing with an index here
4257     CPAN::HandleConfig->load; # we should guarantee loading wherever
4258                               # we rely on Config XXX
4259     $localname ||= $wanted;
4260     my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
4261                                          $localname);
4262     if (
4263         -f $abs_wanted &&
4264         -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
4265         !($force & 1)
4266        ) {
4267         my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
4268         $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
4269                    qq{day$s. I\'ll use that.});
4270         return $abs_wanted;
4271     } else {
4272         $force |= 1; # means we're quite serious about it.
4273     }
4274     return CPAN::FTP->localize($wanted,$abs_wanted,$force);
4275 }
4276
4277 #-> sub CPAN::Index::rd_authindex ;
4278 sub rd_authindex {
4279     my($cl, $index_target) = @_;
4280     my @lines;
4281     return unless defined $index_target;
4282     $CPAN::Frontend->myprint("Going to read $index_target\n");
4283     local(*FH);
4284     tie *FH, 'CPAN::Tarzip', $index_target;
4285     local($/) = "\n";
4286     local($_);
4287     push @lines, split /\012/ while <FH>;
4288     my $i = 0;
4289     my $painted = 0;
4290     foreach (@lines) {
4291         my($userid,$fullname,$email) =
4292             m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/;
4293         $fullname ||= $email;
4294         if ($userid && $fullname && $email){
4295             my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
4296             $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
4297         } else {
4298             CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG;
4299         }
4300         $i++;
4301         while (($painted/76) < ($i/@lines)) {
4302             $CPAN::Frontend->myprint(".");
4303             $painted++;
4304         }
4305         return if $CPAN::Signal;
4306     }
4307     $CPAN::Frontend->myprint("DONE\n");
4308 }
4309
4310 sub userid {
4311   my($self,$dist) = @_;
4312   $dist = $self->{'id'} unless defined $dist;
4313   my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
4314   $ret;
4315 }
4316
4317 #-> sub CPAN::Index::rd_modpacks ;
4318 sub rd_modpacks {
4319     my($self, $index_target) = @_;
4320     return unless defined $index_target;
4321     $CPAN::Frontend->myprint("Going to read $index_target\n");
4322     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
4323     local $_;
4324     CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
4325     my $slurp = "";
4326     my $chunk;
4327     while (my $bytes = $fh->READ(\$chunk,8192)) {
4328         $slurp.=$chunk;
4329     }
4330     my @lines = split /\012/, $slurp;
4331     CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
4332     undef $fh;
4333     # read header
4334     my($line_count,$last_updated);
4335     while (@lines) {
4336         my $shift = shift(@lines);
4337         last if $shift =~ /^\s*$/;
4338         $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
4339         $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
4340     }
4341     CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
4342     if (not defined $line_count) {
4343
4344         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
4345 Please check the validity of the index file by comparing it to more
4346 than one CPAN mirror. I'll continue but problems seem likely to
4347 happen.\a
4348 });
4349
4350         $CPAN::Frontend->mysleep(5);
4351     } elsif ($line_count != scalar @lines) {
4352
4353         $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
4354 contains a Line-Count header of %d but I see %d lines there. Please
4355 check the validity of the index file by comparing it to more than one
4356 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
4357 $index_target, $line_count, scalar(@lines));
4358
4359     }
4360     if (not defined $last_updated) {
4361
4362         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
4363 Please check the validity of the index file by comparing it to more
4364 than one CPAN mirror. I'll continue but problems seem likely to
4365 happen.\a
4366 });
4367
4368         $CPAN::Frontend->mysleep(5);
4369     } else {
4370
4371         $CPAN::Frontend
4372             ->myprint(sprintf qq{  Database was generated on %s\n},
4373                       $last_updated);
4374         $DATE_OF_02 = $last_updated;
4375
4376         my $age = time;
4377         if ($CPAN::META->has_inst('HTTP::Date')) {
4378             require HTTP::Date;
4379             $age -= HTTP::Date::str2time($last_updated);
4380         } else {
4381             $CPAN::Frontend->mywarn("  HTTP::Date not available\n");
4382             require Time::Local;
4383             my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
4384             $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
4385             $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
4386         }
4387         $age /= 3600*24;
4388         if ($age > 30) {
4389
4390             $CPAN::Frontend
4391                 ->mywarn(sprintf
4392                          qq{Warning: This index file is %d days old.
4393   Please check the host you chose as your CPAN mirror for staleness.
4394   I'll continue but problems seem likely to happen.\a\n},
4395                          $age);
4396
4397         } elsif ($age < -1) {
4398
4399             $CPAN::Frontend
4400                 ->mywarn(sprintf
4401                          qq{Warning: Your system date is %d days behind this index file!
4402   System time:          %s
4403   Timestamp index file: %s
4404   Please fix your system time, problems with the make command expected.\n},
4405                          -$age,
4406                          scalar gmtime,
4407                          $DATE_OF_02,
4408                         );
4409
4410         }
4411     }
4412
4413
4414     # A necessity since we have metadata_cache: delete what isn't
4415     # there anymore
4416     my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
4417     CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
4418     my(%exists);
4419     my $i = 0;
4420     my $painted = 0;
4421     foreach (@lines) {
4422         # before 1.56 we split into 3 and discarded the rest. From
4423         # 1.57 we assign remaining text to $comment thus allowing to
4424         # influence isa_perl
4425         my($mod,$version,$dist,$comment) = split " ", $_, 4;
4426         my($bundle,$id,$userid);
4427
4428         if ($mod eq 'CPAN' &&
4429             ! (
4430                CPAN::Queue->exists('Bundle::CPAN') ||
4431                CPAN::Queue->exists('CPAN')
4432               )
4433            ) {
4434             local($^W)= 0;
4435             if ($version > $CPAN::VERSION){
4436                 $CPAN::Frontend->mywarn(qq{
4437   New CPAN.pm version (v$version) available.
4438   [Currently running version is v$CPAN::VERSION]
4439   You might want to try
4440     install CPAN
4441     reload cpan
4442   to both upgrade CPAN.pm and run the new version without leaving
4443   the current session.
4444
4445 }); #});
4446                 $CPAN::Frontend->mysleep(2);
4447                 $CPAN::Frontend->myprint(qq{\n});
4448             }
4449             last if $CPAN::Signal;
4450         } elsif ($mod =~ /^Bundle::(.*)/) {
4451             $bundle = $1;
4452         }
4453
4454         if ($bundle){
4455             $id =  $CPAN::META->instance('CPAN::Bundle',$mod);
4456             # Let's make it a module too, because bundles have so much
4457             # in common with modules.
4458
4459             # Changed in 1.57_63: seems like memory bloat now without
4460             # any value, so commented out
4461
4462             # $CPAN::META->instance('CPAN::Module',$mod);
4463
4464         } else {
4465
4466             # instantiate a module object
4467             $id = $CPAN::META->instance('CPAN::Module',$mod);
4468
4469         }
4470
4471         # Although CPAN prohibits same name with different version the
4472         # indexer may have changed the version for the same distro
4473         # since the last time ("Force Reindexing" feature)
4474         if ($id->cpan_file ne $dist
4475             ||
4476             $id->cpan_version ne $version
4477            ){
4478             $userid = $id->userid || $self->userid($dist);
4479             $id->set(
4480                      'CPAN_USERID' => $userid,
4481                      'CPAN_VERSION' => $version,
4482                      'CPAN_FILE' => $dist,
4483                     );
4484         }
4485
4486         # instantiate a distribution object
4487         if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
4488           # we do not need CONTAINSMODS unless we do something with
4489           # this dist, so we better produce it on demand.
4490
4491           ## my $obj = $CPAN::META->instance(
4492           ##                              'CPAN::Distribution' => $dist
4493           ##                             );
4494           ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
4495         } else {
4496           $CPAN::META->instance(
4497                                 'CPAN::Distribution' => $dist
4498                                )->set(
4499                                       'CPAN_USERID' => $userid,
4500                                       'CPAN_COMMENT' => $comment,
4501                                      );
4502         }
4503         if ($secondtime) {
4504             for my $name ($mod,$dist) {
4505                 # $self->debug("exists name[$name]") if $CPAN::DEBUG;
4506                 $exists{$name} = undef;
4507             }
4508         }
4509         $i++;
4510         while (($painted/76) < ($i/@lines)) {
4511             $CPAN::Frontend->myprint(".");
4512             $painted++;
4513         }
4514         return if $CPAN::Signal;
4515     }
4516     $CPAN::Frontend->myprint("DONE\n");
4517     if ($secondtime) {
4518         for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
4519             for my $o ($CPAN::META->all_objects($class)) {
4520                 next if exists $exists{$o->{ID}};
4521                 $CPAN::META->delete($class,$o->{ID});
4522                 # CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
4523                 #     if $CPAN::DEBUG;
4524             }
4525         }
4526     }
4527 }
4528
4529 #-> sub CPAN::Index::rd_modlist ;
4530 sub rd_modlist {
4531     my($cl,$index_target) = @_;
4532     return unless defined $index_target;
4533     $CPAN::Frontend->myprint("Going to read $index_target\n");
4534     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
4535     local $_;
4536     my $slurp = "";
4537     my $chunk;
4538     while (my $bytes = $fh->READ(\$chunk,8192)) {
4539         $slurp.=$chunk;
4540     }
4541     my @eval2 = split /\012/, $slurp;
4542
4543     while (@eval2) {
4544         my $shift = shift(@eval2);
4545         if ($shift =~ /^Date:\s+(.*)/){
4546             if ($DATE_OF_03 eq $1){
4547                 $CPAN::Frontend->myprint("Unchanged.\n");
4548                 return;
4549             }
4550             ($DATE_OF_03) = $1;
4551         }
4552         last if $shift =~ /^\s*$/;
4553     }
4554     push @eval2, q{CPAN::Modulelist->data;};
4555     local($^W) = 0;
4556     my($comp) = Safe->new("CPAN::Safe1");
4557     my($eval2) = join("\n", @eval2);
4558     CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG;
4559     my $ret = $comp->reval($eval2);
4560     Carp::confess($@) if $@;
4561     return if $CPAN::Signal;
4562     my $i = 0;
4563     my $until = keys(%$ret);
4564     my $painted = 0;
4565     CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
4566     for (keys %$ret) {
4567         my $obj = $CPAN::META->instance("CPAN::Module",$_);
4568         delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
4569         $obj->set(%{$ret->{$_}});
4570         $i++;
4571         while (($painted/76) < ($i/$until)) {
4572             $CPAN::Frontend->myprint(".");
4573             $painted++;
4574         }
4575         return if $CPAN::Signal;
4576     }
4577     $CPAN::Frontend->myprint("DONE\n");
4578 }
4579
4580 #-> sub CPAN::Index::write_metadata_cache ;
4581 sub write_metadata_cache {
4582     my($self) = @_;
4583     return unless $CPAN::Config->{'cache_metadata'};
4584     return unless $CPAN::META->has_usable("Storable");
4585     my $cache;
4586     foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
4587                       CPAN::Distribution)) {
4588         $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
4589     }
4590     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
4591     $cache->{last_time} = $LAST_TIME;
4592     $cache->{DATE_OF_02} = $DATE_OF_02;
4593     $cache->{PROTOCOL} = PROTOCOL;
4594     $CPAN::Frontend->myprint("Going to write $metadata_file\n");
4595     eval { Storable::nstore($cache, $metadata_file) };
4596     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
4597 }
4598
4599 #-> sub CPAN::Index::read_metadata_cache ;
4600 sub read_metadata_cache {
4601     my($self) = @_;
4602     return unless $CPAN::Config->{'cache_metadata'};
4603     return unless $CPAN::META->has_usable("Storable");
4604     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
4605     return unless -r $metadata_file and -f $metadata_file;
4606     $CPAN::Frontend->myprint("Going to read $metadata_file\n");
4607     my $cache;
4608     eval { $cache = Storable::retrieve($metadata_file) };
4609     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
4610     if (!$cache || !UNIVERSAL::isa($cache, 'HASH')){
4611         $LAST_TIME = 0;
4612         return;
4613     }
4614     if (exists $cache->{PROTOCOL}) {
4615         if (PROTOCOL > $cache->{PROTOCOL}) {
4616             $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
4617                                             "with protocol v%s, requiring v%s\n",
4618                                             $cache->{PROTOCOL},
4619                                             PROTOCOL)
4620                                    );
4621             return;
4622         }
4623     } else {
4624         $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
4625                                 "with protocol v1.0\n");
4626         return;
4627     }
4628     my $clcnt = 0;
4629     my $idcnt = 0;
4630     while(my($class,$v) = each %$cache) {
4631         next unless $class =~ /^CPAN::/;
4632         $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
4633         while (my($id,$ro) = each %$v) {
4634             $CPAN::META->{readwrite}{$class}{$id} ||=
4635                 $class->new(ID=>$id, RO=>$ro);
4636             $idcnt++;
4637         }
4638         $clcnt++;
4639     }
4640     unless ($clcnt) { # sanity check
4641         $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
4642         return;
4643     }
4644     if ($idcnt < 1000) {
4645         $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
4646                                  "in $metadata_file\n");
4647         return;
4648     }
4649     $CPAN::META->{PROTOCOL} ||=
4650         $cache->{PROTOCOL}; # reading does not up or downgrade, but it
4651                             # does initialize to some protocol
4652     $LAST_TIME = $cache->{last_time};
4653     $DATE_OF_02 = $cache->{DATE_OF_02};
4654     $CPAN::Frontend->myprint("  Database was generated on $DATE_OF_02\n")
4655         if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
4656     return;
4657 }
4658
4659 package CPAN::InfoObj;
4660 use strict;
4661
4662 sub ro {
4663     my $self = shift;
4664     exists $self->{RO} and return $self->{RO};
4665 }
4666
4667 #-> sub CPAN::InfoObj::cpan_userid
4668 sub cpan_userid {
4669     my $self = shift;
4670     my $ro = $self->ro;
4671     if ($ro) {
4672         return $ro->{CPAN_USERID} || "N/A";
4673     } else {
4674         $self->debug("ID[$self->{ID}]");
4675         # N/A for bundles found locally
4676         return "N/A";
4677     }
4678 }
4679
4680 sub id { shift->{ID}; }
4681
4682 #-> sub CPAN::InfoObj::new ;
4683 sub new {
4684     my $this = bless {}, shift;
4685     %$this = @_;
4686     $this
4687 }
4688
4689 # The set method may only be used by code that reads index data or
4690 # otherwise "objective" data from the outside world. All session
4691 # related material may do anything else with instance variables but
4692 # must not touch the hash under the RO attribute. The reason is that
4693 # the RO hash gets written to Metadata file and is thus persistent.
4694
4695 #-> sub CPAN::InfoObj::safe_chdir ;
4696 sub safe_chdir {
4697   my($self,$todir) = @_;
4698   # we die if we cannot chdir and we are debuggable
4699   Carp::confess("safe_chdir called without todir argument")
4700         unless defined $todir and length $todir;
4701   if (chdir $todir) {
4702     $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
4703         if $CPAN::DEBUG;
4704   } else {
4705     if (-e $todir) {
4706         unless (-x $todir) {
4707             unless (chmod 0755, $todir) {
4708                 my $cwd = CPAN::anycwd();
4709                 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
4710                                         "permission to change the permission; cannot ".
4711                                         "chdir to '$todir'\n");
4712                 $CPAN::Frontend->mysleep(5);
4713                 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
4714                                        qq{to todir[$todir]: $!});
4715             }
4716         }
4717     } else {
4718         $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n");
4719     }
4720     if (chdir $todir) {
4721       $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
4722           if $CPAN::DEBUG;
4723     } else {
4724       my $cwd = CPAN::anycwd();
4725       $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
4726                              qq{to todir[$todir] (a chmod has been issued): $!});
4727     }
4728   }
4729 }
4730
4731 #-> sub CPAN::InfoObj::set ;
4732 sub set {
4733     my($self,%att) = @_;
4734     my $class = ref $self;
4735
4736     # This must be ||=, not ||, because only if we write an empty
4737     # reference, only then the set method will write into the readonly
4738     # area. But for Distributions that spring into existence, maybe
4739     # because of a typo, we do not like it that they are written into
4740     # the readonly area and made permanent (at least for a while) and
4741     # that is why we do not "allow" other places to call ->set.
4742     unless ($self->id) {
4743         CPAN->debug("Bug? Empty ID, rejecting");
4744         return;
4745     }
4746     my $ro = $self->{RO} =
4747         $CPAN::META->{readonly}{$class}{$self->id} ||= {};
4748
4749     while (my($k,$v) = each %att) {
4750         $ro->{$k} = $v;
4751     }
4752 }
4753
4754 #-> sub CPAN::InfoObj::as_glimpse ;
4755 sub as_glimpse {
4756     my($self) = @_;
4757     my(@m);
4758     my $class = ref($self);
4759     $class =~ s/^CPAN:://;
4760     my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID};
4761     push @m, sprintf "%-15s %s\n", $class, $id;
4762     join "", @m;
4763 }
4764
4765 #-> sub CPAN::InfoObj::as_string ;
4766 sub as_string {
4767     my($self) = @_;
4768     my(@m);
4769     my $class = ref($self);
4770     $class =~ s/^CPAN:://;
4771     push @m, $class, " id = $self->{ID}\n";
4772     my $ro;
4773     unless ($ro = $self->ro) {
4774         if (substr($self->{ID},-1,1) eq ".") { # directory
4775             $ro = +{};
4776         } else {
4777             $CPAN::Frontend->mydie("Unknown object $self->{ID}");
4778         }
4779     }
4780     for (sort keys %$ro) {
4781         # next if m/^(ID|RO)$/;
4782         my $extra = "";
4783         if ($_ eq "CPAN_USERID") {
4784             $extra .= " (";
4785             $extra .= $self->fullname;
4786             my $email; # old perls!
4787             if ($email = $CPAN::META->instance("CPAN::Author",
4788                                                $self->cpan_userid
4789                                               )->email) {
4790                 $extra .= " <$email>";
4791             } else {
4792                 $extra .= " <no email>";
4793             }
4794             $extra .= ")";
4795         } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
4796             push @m, sprintf "    %-12s %s\n", $_, $self->fullname;
4797             next;
4798         }
4799         next unless defined $ro->{$_};
4800         push @m, sprintf "    %-12s %s%s\n", $_, $ro->{$_}, $extra;
4801     }
4802   KEY: for (sort keys %$self) {
4803         next if m/^(ID|RO)$/;
4804         unless (defined $self->{$_}) {
4805             delete $self->{$_};
4806             next KEY;
4807         }
4808         if (ref($self->{$_}) eq "ARRAY") {
4809           push @m, sprintf "    %-12s %s\n", $_, "@{$self->{$_}}";
4810         } elsif (ref($self->{$_}) eq "HASH") {
4811             my $value;
4812             if (/^CONTAINSMODS$/) {
4813                 $value = join(" ",sort keys %{$self->{$_}});
4814             } elsif (/^prereq_pm$/) {
4815                 my @value;
4816                 my $v = $self->{$_};
4817                 for my $x (sort keys %$v) {
4818                     my @svalue;
4819                     for my $y (sort keys %{$v->{$x}}) {
4820                         push @svalue, "$y=>$v->{$x}{$y}";
4821                     }
4822                     push @value, "$x\:" . join ",", @svalue if @svalue;
4823                 }
4824                 $value = join ";", @value;
4825             } else {
4826                 $value = $self->{$_};
4827             }
4828           push @m, sprintf(
4829                            "    %-12s %s\n",
4830                            $_,
4831                            $value,
4832                           );
4833         } else {
4834           push @m, sprintf "    %-12s %s\n", $_, $self->{$_};
4835         }
4836     }
4837     join "", @m, "\n";
4838 }
4839
4840 #-> sub CPAN::InfoObj::fullname ;
4841 sub fullname {
4842     my($self) = @_;
4843     $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
4844 }
4845
4846 #-> sub CPAN::InfoObj::dump ;
4847 sub dump {
4848   my($self, $what) = @_;
4849   unless ($CPAN::META->has_inst("Data::Dumper")) {
4850       $CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
4851   }
4852   local $Data::Dumper::Sortkeys;
4853   $Data::Dumper::Sortkeys = 1;
4854   my $out = Data::Dumper::Dumper($what ? eval $what : $self);
4855   if (length $out > 100000) {
4856       my $fh_pager = FileHandle->new;
4857       local($SIG{PIPE}) = "IGNORE";
4858       my $pager = $CPAN::Config->{'pager'} || "cat";
4859       $fh_pager->open("|$pager")
4860           or die "Could not open pager $pager\: $!";
4861       $fh_pager->print($out);
4862       close $fh_pager;
4863   } else {
4864       $CPAN::Frontend->myprint($out);
4865   }
4866 }
4867
4868 package CPAN::Author;
4869 use strict;
4870
4871 #-> sub CPAN::Author::force
4872 sub force {
4873     my $self = shift;
4874     $self->{force}++;
4875 }
4876
4877 #-> sub CPAN::Author::force
4878 sub unforce {
4879     my $self = shift;
4880     delete $self->{force};
4881 }
4882
4883 #-> sub CPAN::Author::id
4884 sub id {
4885     my $self = shift;
4886     my $id = $self->{ID};
4887     $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
4888     $id;
4889 }
4890
4891 #-> sub CPAN::Author::as_glimpse ;
4892 sub as_glimpse {
4893     my($self) = @_;
4894     my(@m);
4895     my $class = ref($self);
4896     $class =~ s/^CPAN:://;
4897     push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
4898                      $class,
4899                      $self->{ID},
4900                      $self->fullname,
4901                      $self->email);
4902     join "", @m;
4903 }
4904
4905 #-> sub CPAN::Author::fullname ;
4906 sub fullname {
4907     shift->ro->{FULLNAME};
4908 }
4909 *name = \&fullname;
4910
4911 #-> sub CPAN::Author::email ;
4912 sub email    { shift->ro->{EMAIL}; }
4913
4914 #-> sub CPAN::Author::ls ;
4915 sub ls {
4916     my $self = shift;
4917     my $glob = shift || "";
4918     my $silent = shift || 0;
4919     my $id = $self->id;
4920
4921     # adapted from CPAN::Distribution::verifyCHECKSUM ;
4922     my(@csf); # chksumfile
4923     @csf = $self->id =~ /(.)(.)(.*)/;
4924     $csf[1] = join "", @csf[0,1];
4925     $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
4926     my(@dl);
4927     @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
4928     unless (grep {$_->[2] eq $csf[1]} @dl) {
4929         $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
4930         return;
4931     }
4932     @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
4933     unless (grep {$_->[2] eq $csf[2]} @dl) {
4934         $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
4935         return;
4936     }
4937     @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
4938     if ($glob) {
4939         if ($CPAN::META->has_inst("Text::Glob")) {
4940             my $rglob = Text::Glob::glob_to_regex($glob);
4941             @dl = grep { $_->[2] =~ /$rglob/ } @dl;
4942         } else {
4943             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
4944         }
4945     }
4946     $CPAN::Frontend->myprint(join "", map {
4947         sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
4948     } sort { $a->[2] cmp $b->[2] } @dl);
4949     @dl;
4950 }
4951
4952 # returns an array of arrays, the latter contain (size,mtime,filename)
4953 #-> sub CPAN::Author::dir_listing ;
4954 sub dir_listing {
4955     my $self = shift;
4956     my $chksumfile = shift;
4957     my $recursive = shift;
4958     my $may_ftp = shift;
4959
4960     my $lc_want =
4961         File::Spec->catfile($CPAN::Config->{keep_source_where},
4962                             "authors", "id", @$chksumfile);
4963
4964     my $fh;
4965
4966     # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
4967     # hazard.  (Without GPG installed they are not that much better,
4968     # though.)
4969     $fh = FileHandle->new;
4970     if (open($fh, $lc_want)) {
4971         my $line = <$fh>; close $fh;
4972         unlink($lc_want) unless $line =~ /PGP/;
4973     }
4974
4975     local($") = "/";
4976     # connect "force" argument with "index_expire".
4977     my $force = $self->{force};
4978     if (my @stat = stat $lc_want) {
4979         $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
4980     }
4981     my $lc_file;
4982     if ($may_ftp) {
4983         $lc_file = CPAN::FTP->localize(
4984                                        "authors/id/@$chksumfile",
4985                                        $lc_want,
4986                                        $force,
4987                                       );
4988         unless ($lc_file) {
4989             $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
4990             $chksumfile->[-1] .= ".gz";
4991             $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
4992                                            "$lc_want.gz",1);
4993             if ($lc_file) {
4994                 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
4995                 eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
4996             } else {
4997                 return;
4998             }
4999         }
5000     } else {
5001         $lc_file = $lc_want;
5002         # we *could* second-guess and if the user has a file: URL,
5003         # then we could look there. But on the other hand, if they do
5004         # have a file: URL, wy did they choose to set
5005         # $CPAN::Config->{show_upload_date} to false?
5006     }
5007
5008     # adapted from CPAN::Distribution::CHECKSUM_check_file ;
5009     $fh = FileHandle->new;
5010     my($cksum);
5011     if (open $fh, $lc_file){
5012         local($/);
5013         my $eval = <$fh>;
5014         $eval =~ s/\015?\012/\n/g;
5015         close $fh;
5016         my($comp) = Safe->new();
5017         $cksum = $comp->reval($eval);
5018         if ($@) {
5019             rename $lc_file, "$lc_file.bad";
5020             Carp::confess($@) if $@;
5021         }
5022     } elsif ($may_ftp) {
5023         Carp::carp "Could not open '$lc_file' for reading.";
5024     } else {
5025         # Maybe should warn: "You may want to set show_upload_date to a true value"
5026         return;
5027     }
5028     my(@result,$f);
5029     for $f (sort keys %$cksum) {
5030         if (exists $cksum->{$f}{isdir}) {
5031             if ($recursive) {
5032                 my(@dir) = @$chksumfile;
5033                 pop @dir;
5034                 push @dir, $f, "CHECKSUMS";
5035                 push @result, map {
5036                     [$_->[0], $_->[1], "$f/$_->[2]"]
5037                 } $self->dir_listing(\@dir,1,$may_ftp);
5038             } else {
5039                 push @result, [ 0, "-", $f ];
5040             }
5041         } else {
5042             push @result, [
5043                            ($cksum->{$f}{"size"}||0),
5044                            $cksum->{$f}{"mtime"}||"---",
5045                            $f
5046                           ];
5047         }
5048     }
5049     @result;
5050 }
5051
5052 package CPAN::Distribution;
5053 use strict;
5054
5055 # Accessors
5056 sub cpan_comment {
5057     my $self = shift;
5058     my $ro = $self->ro or return;
5059     $ro->{CPAN_COMMENT}
5060 }
5061
5062 # CPAN::Distribution::undelay
5063 sub undelay {
5064     my $self = shift;
5065     delete $self->{later};
5066 }
5067
5068 # add the A/AN/ stuff
5069 # CPAN::Distribution::normalize
5070 sub normalize {
5071     my($self,$s) = @_;
5072     $s = $self->id unless defined $s;
5073     if (substr($s,-1,1) eq ".") {
5074         # using a global because we are sometimes called as static method
5075         if (!$CPAN::META->{LOCK}
5076             && !$CPAN::Have_warned->{"$s is unlocked"}++
5077            ) {
5078             $CPAN::Frontend->mywarn("You are visiting the local directory
5079   '$s'
5080   without lock, take care that concurrent processes do not do likewise.\n");
5081             $CPAN::Frontend->mysleep(1);
5082         }
5083         if ($s eq ".") {
5084             $s = "$CPAN::iCwd/.";
5085         } elsif (File::Spec->file_name_is_absolute($s)) {
5086         } elsif (File::Spec->can("rel2abs")) {
5087             $s = File::Spec->rel2abs($s);
5088         } else {
5089             $CPAN::Frontend->mydie("Your File::Spec is too old, please upgrade File::Spec");
5090         }
5091         CPAN->debug("s[$s]") if $CPAN::DEBUG;
5092         unless ($CPAN::META->exists("CPAN::Distribution", $s)) {
5093             for ($CPAN::META->instance("CPAN::Distribution", $s)) {
5094                 $_->{build_dir} = $s;
5095                 $_->{archived} = "local_directory";
5096                 $_->{unwrapped} = CPAN::Distrostatus->new("YES -- local_directory");
5097             }
5098         }
5099     } elsif (
5100         $s =~ tr|/|| == 1
5101         or
5102         $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
5103        ) {
5104         return $s if $s =~ m:^N/A|^Contact Author: ;
5105         $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
5106             $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
5107         CPAN->debug("s[$s]") if $CPAN::DEBUG;
5108     }
5109     $s;
5110 }
5111
5112 #-> sub CPAN::Distribution::author ;
5113 sub author {
5114     my($self) = @_;
5115     my($authorid);
5116     if (substr($self->id,-1,1) eq ".") {
5117         $authorid = "LOCAL";
5118     } else {
5119         ($authorid) = $self->pretty_id =~ /^([\w\-]+)/;
5120     }
5121     CPAN::Shell->expand("Author",$authorid);
5122 }
5123
5124 # tries to get the yaml from CPAN instead of the distro itself:
5125 # EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels
5126 sub fast_yaml {
5127     my($self) = @_;
5128     my $meta = $self->pretty_id;
5129     $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/;
5130     my(@ls) = CPAN::Shell->globls($meta);
5131     my $norm = $self->normalize($meta);
5132
5133     my($local_file);
5134     my($local_wanted) =
5135         File::Spec->catfile(
5136                             $CPAN::Config->{keep_source_where},
5137                             "authors",
5138                             "id",
5139                             split(/\//,$norm)
5140                            );
5141     $self->debug("Doing localize") if $CPAN::DEBUG;
5142     unless ($local_file =
5143             CPAN::FTP->localize("authors/id/$norm",
5144                                 $local_wanted)) {
5145         $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n");
5146     }
5147     my $yaml = CPAN->_yaml_loadfile($local_file)->[0];
5148 }
5149
5150 #-> sub CPAN::Distribution::cpan_userid
5151 sub cpan_userid {
5152     my $self = shift;
5153     if ($self->{ID} =~ m{[A-Z]/[A-Z\-]{2}/([A-Z\-]+)/}) {
5154         return $1;
5155     }
5156     return $self->SUPER::cpan_userid;
5157 }
5158
5159 #-> sub CPAN::Distribution::pretty_id
5160 sub pretty_id {
5161     my $self = shift;
5162     my $id = $self->id;
5163     return $id unless $id =~ m|^./../|;
5164     substr($id,5);
5165 }
5166
5167 # mark as dirty/clean
5168 #-> sub CPAN::Distribution::color_cmd_tmps ;
5169 sub color_cmd_tmps {
5170     my($self) = shift;
5171     my($depth) = shift || 0;
5172     my($color) = shift || 0;
5173     my($ancestors) = shift || [];
5174     # a distribution needs to recurse into its prereq_pms
5175
5176     return if exists $self->{incommandcolor}
5177         && $self->{incommandcolor}==$color;
5178     if ($depth>=100){
5179         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
5180     }
5181     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5182     my $prereq_pm = $self->prereq_pm;
5183     if (defined $prereq_pm) {
5184       PREREQ: for my $pre (keys %{$prereq_pm->{requires}||{}},
5185                            keys %{$prereq_pm->{build_requires}||{}}) {
5186             next PREREQ if $pre eq "perl";
5187             my $premo;
5188             unless ($premo = CPAN::Shell->expand("Module",$pre)) {
5189                 $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n");
5190                 $CPAN::Frontend->mysleep(2);
5191                 next PREREQ;
5192             }
5193             $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5194         }
5195     }
5196     if ($color==0) {
5197         delete $self->{sponsored_mods};
5198         delete $self->{badtestcnt};
5199     }
5200     $self->{incommandcolor} = $color;
5201 }
5202
5203 #-> sub CPAN::Distribution::as_string ;
5204 sub as_string {
5205   my $self = shift;
5206   $self->containsmods;
5207   $self->upload_date;
5208   $self->SUPER::as_string(@_);
5209 }
5210
5211 #-> sub CPAN::Distribution::containsmods ;
5212 sub containsmods {
5213   my $self = shift;
5214   return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
5215   my $dist_id = $self->{ID};
5216   for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
5217     my $mod_file = $mod->cpan_file or next;
5218     my $mod_id = $mod->{ID} or next;
5219     # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
5220     # sleep 1;
5221     $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
5222   }
5223   keys %{$self->{CONTAINSMODS}};
5224 }
5225
5226 #-> sub CPAN::Distribution::upload_date ;
5227 sub upload_date {
5228   my $self = shift;
5229   return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
5230   my(@local_wanted) = split(/\//,$self->id);
5231   my $filename = pop @local_wanted;
5232   push @local_wanted, "CHECKSUMS";
5233   my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
5234   return unless $author;
5235   my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
5236   return unless @dl;
5237   my($dirent) = grep { $_->[2] eq $filename } @dl;
5238   # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
5239   return unless $dirent->[1];
5240   return $self->{UPLOAD_DATE} = $dirent->[1];
5241 }
5242
5243 #-> sub CPAN::Distribution::uptodate ;
5244 sub uptodate {
5245     my($self) = @_;
5246     my $c;
5247     foreach $c ($self->containsmods) {
5248         my $obj = CPAN::Shell->expandany($c);
5249         unless ($obj->uptodate){
5250             my $id = $self->pretty_id;
5251             $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG;
5252             return 0;
5253         }
5254     }
5255     return 1;
5256 }
5257
5258 #-> sub CPAN::Distribution::called_for ;
5259 sub called_for {
5260     my($self,$id) = @_;
5261     $self->{CALLED_FOR} = $id if defined $id;
5262     return $self->{CALLED_FOR};
5263 }
5264
5265 #-> sub CPAN::Distribution::get ;
5266 sub get {
5267     my($self) = @_;
5268     if (my $goto = $self->prefs->{goto}) {
5269         $CPAN::Frontend->mywarn
5270             (sprintf(
5271                      "delegating to '%s' as specified in prefs file '%s' doc %d\n",
5272                      $goto,
5273                      $self->{prefs_file},
5274                      $self->{prefs_file_doc},
5275                     ));
5276         return $self->goto($goto);
5277     }
5278     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
5279                            ? $ENV{PERL5LIB}
5280                            : ($ENV{PERLLIB} || "");
5281
5282     $CPAN::META->set_perl5lib;
5283     local $ENV{MAKEFLAGS}; # protect us from outer make calls
5284
5285   EXCUSE: {
5286         my @e;
5287         if ($self->prefs->{disabled}) {
5288             push @e, sprintf(
5289                              "disabled via prefs file '%s' doc %d",
5290                              $self->{prefs_file},
5291                              $self->{prefs_file_doc},
5292                             );
5293         }
5294         exists $self->{build_dir} and push @e,
5295             "Is already unwrapped into directory $self->{build_dir}";
5296
5297         exists $self->{unwrapped} and (
5298                                        UNIVERSAL::can($self->{unwrapped},"failed") ?
5299                                        $self->{unwrapped}->failed :
5300                                        $self->{unwrapped} =~ /^NO/
5301                                       )
5302             and push @e, "Unwrapping had some problem, won't try again without force";
5303
5304         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
5305     }
5306     my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
5307
5308     #
5309     # Get the file on local disk
5310     #
5311
5312     my($local_file);
5313     my($local_wanted) =
5314         File::Spec->catfile(
5315                             $CPAN::Config->{keep_source_where},
5316                             "authors",
5317                             "id",
5318                             split(/\//,$self->id)
5319                            );
5320
5321     $self->debug("Doing localize") if $CPAN::DEBUG;
5322     unless ($local_file =
5323             CPAN::FTP->localize("authors/id/$self->{ID}",
5324                                 $local_wanted)) {
5325         my $note = "";
5326         if ($CPAN::Index::DATE_OF_02) {
5327             $note = "Note: Current database in memory was generated ".
5328                 "on $CPAN::Index::DATE_OF_02\n";
5329         }
5330         $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
5331     }
5332
5333     $self->debug("local_wanted[$local_wanted]local_file[$local_file]") if $CPAN::DEBUG;
5334     $self->{localfile} = $local_file;
5335     return if $CPAN::Signal;
5336
5337     #
5338     # Check integrity
5339     #
5340     if ($CPAN::META->has_inst("Digest::SHA")) {
5341         $self->debug("Digest::SHA is installed, verifying");
5342         $self->verifyCHECKSUM;
5343     } else {
5344         $self->debug("Digest::SHA is NOT installed");
5345     }
5346     return if $CPAN::Signal;
5347
5348     #
5349     # Create a clean room and go there
5350     #
5351     $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
5352     my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
5353     $self->safe_chdir($builddir);
5354     $self->debug("Removing tmp-$$") if $CPAN::DEBUG;
5355     File::Path::rmtree("tmp-$$");
5356     unless (mkdir "tmp-$$", 0755) {
5357         $CPAN::Frontend->unrecoverable_error(<<EOF);
5358 Couldn't mkdir '$builddir/tmp-$$': $!
5359
5360 Cannot continue: Please find the reason why I cannot make the
5361 directory
5362 $builddir/tmp-$$
5363 and fix the problem, then retry.
5364
5365 EOF
5366     }
5367     if ($CPAN::Signal){
5368         $self->safe_chdir($sub_wd);
5369         return;
5370     }
5371     $self->safe_chdir("tmp-$$");
5372
5373     #
5374     # Unpack the goods
5375     #
5376     my $ct = eval{CPAN::Tarzip->new($local_file)};
5377     unless ($ct) {
5378         $self->{unwrapped} = CPAN::Distrostatus->new("NO");
5379         delete $self->{build_dir};
5380         return;
5381     }
5382     if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i){
5383         $self->{was_uncompressed}++ unless eval{$ct->gtest()};
5384         $self->untar_me($ct);
5385     } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
5386         $self->unzip_me($ct);
5387     } else {
5388         $self->{was_uncompressed}++ unless $ct->gtest();
5389         $local_file = $self->handle_singlefile($local_file);
5390 #    } else {
5391 #       $self->{archived} = "NO";
5392 #        $self->safe_chdir($sub_wd);
5393 #        return;
5394     }
5395
5396     # we are still in the tmp directory!
5397     # Let's check if the package has its own directory.
5398     my $dh = DirHandle->new(File::Spec->curdir)
5399         or Carp::croak("Couldn't opendir .: $!");
5400     my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
5401     $dh->close;
5402     my ($packagedir);
5403     # XXX here we want in each branch File::Temp to protect all build_dir directories
5404     if (CPAN->has_inst("File::Temp")) {
5405         my $tdir_base;
5406         my $from_dir;
5407         my @dirents;
5408         if (@readdir == 1 && -d $readdir[0]) {
5409             $tdir_base = $readdir[0];
5410             $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]);
5411             my $dh2 = DirHandle->new($from_dir)
5412                 or Carp::croak("Couldn't opendir $from_dir: $!");
5413             @dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC??
5414         } else {
5415             my $userid = $self->cpan_userid;
5416             CPAN->debug("userid[$userid]");
5417             if (!$userid or $userid eq "N/A") {
5418                 $userid = "anon";
5419             }
5420             $tdir_base = $userid;
5421             $from_dir = File::Spec->curdir;
5422             @dirents = @readdir;
5423         }
5424         $packagedir = File::Temp::tempdir(
5425                                           "$tdir_base-XXXXXX",
5426                                           DIR => $builddir,
5427                                           CLEANUP => 0,
5428                                          );
5429         my $f;
5430         for $f (@dirents) { # is already without "." and ".."
5431             my $from = File::Spec->catdir($from_dir,$f);
5432             my $to = File::Spec->catdir($packagedir,$f);
5433             File::Copy::move($from,$to) or Carp::confess("Couldn't move $from to $to: $!");
5434         }
5435     } else { # older code below, still better than nothing when there is no File::Temp
5436         my($distdir);
5437         if (@readdir == 1 && -d $readdir[0]) {
5438             $distdir = $readdir[0];
5439             $packagedir = File::Spec->catdir($builddir,$distdir);
5440             $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
5441                 if $CPAN::DEBUG;
5442             -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
5443                                                         "$packagedir\n");
5444             File::Path::rmtree($packagedir);
5445             unless (File::Copy::move($distdir,$packagedir)) {
5446                 $CPAN::Frontend->unrecoverable_error(<<EOF);
5447 Couldn't move '$distdir' to '$packagedir': $!
5448
5449 Cannot continue: Please find the reason why I cannot move
5450 $builddir/tmp-$$/$distdir
5451 to
5452 $packagedir
5453 and fix the problem, then retry
5454
5455 EOF
5456             }
5457             $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
5458                                  $distdir,
5459                                  $packagedir,
5460                                  -e $packagedir,
5461                                  -d $packagedir,
5462                                 )) if $CPAN::DEBUG;
5463         } else {
5464             my $userid = $self->cpan_userid;
5465             CPAN->debug("userid[$userid]");
5466             if (!$userid or $userid eq "N/A") {
5467                 $userid = "anon";
5468             }
5469             my $pragmatic_dir = $userid . '000';
5470             $pragmatic_dir =~ s/\W_//g;
5471             $pragmatic_dir++ while -d "../$pragmatic_dir";
5472             $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
5473             $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
5474             File::Path::mkpath($packagedir);
5475             my($f);
5476             for $f (@readdir) { # is already without "." and ".."
5477                 my $to = File::Spec->catdir($packagedir,$f);
5478                 File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
5479             }
5480         }
5481     }
5482     if ($CPAN::Signal){
5483         $self->safe_chdir($sub_wd);
5484         return;
5485     }
5486
5487     $self->{'build_dir'} = $packagedir;
5488     $self->safe_chdir($builddir);
5489     File::Path::rmtree("tmp-$$");
5490
5491     $self->safe_chdir($packagedir);
5492     $self->_signature_business();
5493     $self->safe_chdir($builddir);
5494     return if $CPAN::Signal;
5495
5496
5497     my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
5498     my($mpl_exists) = -f $mpl;
5499     unless ($mpl_exists) {
5500         # NFS has been reported to have racing problems after the
5501         # renaming of a directory in some environments.
5502         # This trick helps.
5503         $CPAN::Frontend->mysleep(1);
5504         my $mpldh = DirHandle->new($packagedir)
5505             or Carp::croak("Couldn't opendir $packagedir: $!");
5506         $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
5507         $mpldh->close;
5508     }
5509     my $prefer_installer = "eumm"; # eumm|mb
5510     if (-f File::Spec->catfile($packagedir,"Build.PL")) {
5511         if ($mpl_exists) { # they *can* choose
5512             $prefer_installer = CPAN::HandleConfig->prefs_lookup($self,
5513                                                                  q{prefer_installer});
5514         } else {
5515             $prefer_installer = "mb";
5516         }
5517     }
5518     return unless $self->patch;
5519     if (lc($prefer_installer) eq "mb") {
5520         $self->{modulebuild} = 1;
5521     } elsif (! $mpl_exists) {
5522         $self->_edge_cases($mpl,$packagedir,$local_file);
5523     }
5524     if ($self->{build_dir}
5525         &&
5526         $CPAN::Config->{build_dir_reuse}
5527        ) {
5528         $self->store_persistent_state;
5529     }
5530
5531     return $self;
5532 }
5533
5534 #-> CPAN::Distribution::store_persistent_state
5535 sub store_persistent_state {
5536     my($self) = @_;
5537     my $dir = $self->{build_dir};
5538     unless (File::Basename::dirname($dir) eq $CPAN::Config->{build_dir}) {
5539         $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
5540                                 "will not store persistent state\n");
5541         return;
5542     }
5543     my $file = sprintf "%s.yml", $dir;
5544     CPAN->_yaml_dumpfile(
5545                          $file,
5546                          {
5547                           time => time,
5548                           perl => CPAN::_perl_fingerprint,
5549                           distribution => $self,
5550                          }
5551                         );
5552 }
5553
5554 #-> CPAN::Distribution::patch
5555 sub try_download {
5556     my($self,$patch) = @_;
5557     my $norm = $self->normalize($patch);
5558     my($local_wanted) =
5559         File::Spec->catfile(
5560                             $CPAN::Config->{keep_source_where},
5561                             "authors",
5562                             "id",
5563                             split(/\//,$norm),
5564                             );
5565     $self->debug("Doing localize") if $CPAN::DEBUG;
5566     return CPAN::FTP->localize("authors/id/$norm",
5567                                $local_wanted);
5568 }
5569
5570 #-> CPAN::Distribution::patch
5571 sub patch {
5572     my($self) = @_;
5573     if (my $patches = $self->prefs->{patches}) {
5574         return unless @$patches;
5575         $self->safe_chdir($self->{build_dir});
5576         CPAN->debug("patches[$patches]");
5577         my $patchbin = $CPAN::Config->{patch};
5578         unless ($patchbin && length $patchbin) {
5579             $CPAN::Frontend->mydie("No external patch command configured\n\n".
5580                                    "Please run 'o conf init /patch/'\n\n");
5581         }
5582         unless (MM->maybe_command($patchbin)) {
5583             $CPAN::Frontend->mydie("No external patch command available\n\n".
5584                                    "Please run 'o conf init /patch/'\n\n");
5585         }
5586         $patchbin = CPAN::HandleConfig->safe_quote($patchbin);
5587         local $ENV{PATCH_GET} = 0; # shall replace -g0 which is not
5588                                    # supported everywhere (and then,
5589                                    # not ever necessary there)
5590         my $stdpatchargs = "-N --fuzz=3";
5591         my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches");
5592         $CPAN::Frontend->myprint("Going to apply $countedpatches:\n");
5593         for my $patch (@$patches) {
5594             unless (-f $patch) {
5595                 if (my $trydl = $self->try_download($patch)) {
5596                     $patch = $trydl;
5597                 } else {
5598                     my $fail = "Could not find patch '$patch'";
5599                     $CPAN::Frontend->mywarn("$fail; cannot continue\n");
5600                     $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
5601                     delete $self->{build_dir};
5602                     return;
5603                 }
5604             }
5605             $CPAN::Frontend->myprint("  $patch\n");
5606             my $readfh = CPAN::Tarzip->TIEHANDLE($patch);
5607             my $thispatchargs = join " ", $stdpatchargs, $self->_patch_p_parameter($readfh);
5608             CPAN->debug("thispatchargs[$thispatchargs]") if $CPAN::DEBUG;
5609             $readfh = CPAN::Tarzip->TIEHANDLE($patch);
5610             my $writefh = FileHandle->new;
5611             unless (open $writefh, "|$patchbin $thispatchargs") {
5612                 my $fail = "Could not fork '$patchbin $thispatchargs'";
5613                 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
5614                 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
5615                 delete $self->{build_dir};
5616                 return;
5617             }
5618             while (my $x = $readfh->READLINE) {
5619                 print $writefh $x;
5620             }
5621             unless (close $writefh) {
5622                 my $fail = "Could not apply patch '$patch'";
5623                 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
5624                 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
5625                 delete $self->{build_dir};
5626                 return;
5627             }
5628         }
5629         $self->{patched}++;
5630     }
5631     return 1;
5632 }
5633
5634 sub _patch_p_parameter {
5635     my($self,$fh) = @_;
5636     my $cnt_files   = 0;
5637     my $cnt_p0files = 0;
5638     local($_);
5639     while ($_ = $fh->READLINE) {
5640         next unless /^[\*\+]{3}\s(\S+)/;
5641         my $file = $1;
5642         $cnt_files++;
5643         $cnt_p0files++ if -f $file;
5644         CPAN->debug("file[$file]cnt_files[$cnt_files]cnt_p0files[$cnt_p0files]") if $CPAN::DEBUG;
5645     }
5646     return "-p1" unless $cnt_files;
5647     return $cnt_files==$cnt_p0files ? "-p0" : "-p1";
5648 }
5649
5650 #-> sub CPAN::Distribution::_edge_cases
5651 # with "configure" or "Makefile" or single file scripts
5652 sub _edge_cases {
5653     my($self,$mpl,$packagedir,$local_file) = @_;
5654     $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
5655                          $mpl,
5656                          CPAN::anycwd(),
5657                         )) if $CPAN::DEBUG;
5658     my($configure) = File::Spec->catfile($packagedir,"Configure");
5659     if (-f $configure) {
5660         # do we have anything to do?
5661         $self->{configure} = $configure;
5662     } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
5663         $CPAN::Frontend->mywarn(qq{
5664 Package comes with a Makefile and without a Makefile.PL.
5665 We\'ll try to build it with that Makefile then.
5666 });
5667         $self->{writemakefile} = CPAN::Distrostatus->new("YES");
5668         $CPAN::Frontend->mysleep(2);
5669     } else {
5670         my $cf = $self->called_for || "unknown";
5671         if ($cf =~ m|/|) {
5672             $cf =~ s|.*/||;
5673             $cf =~ s|\W.*||;
5674         }
5675         $cf =~ s|[/\\:]||g;     # risk of filesystem damage
5676         $cf = "unknown" unless length($cf);
5677         $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
5678   (The test -f "$mpl" returned false.)
5679   Writing one on our own (setting NAME to $cf)\a\n});
5680         $self->{had_no_makefile_pl}++;
5681         $CPAN::Frontend->mysleep(3);
5682
5683         # Writing our own Makefile.PL
5684
5685         my $script = "";
5686         if ($self->{archived} eq "maybe_pl") {
5687             my $fh = FileHandle->new;
5688             my $script_file = File::Spec->catfile($packagedir,$local_file);
5689             $fh->open($script_file)
5690                 or Carp::croak("Could not open $script_file: $!");
5691             local $/ = "\n";
5692             # name parsen und prereq
5693             my($state) = "poddir";
5694             my($name, $prereq) = ("", "");
5695             while (<$fh>) {
5696                 if ($state eq "poddir" && /^=head\d\s+(\S+)/) {
5697                     if ($1 eq 'NAME') {
5698                         $state = "name";
5699                     } elsif ($1 eq 'PREREQUISITES') {
5700                         $state = "prereq";
5701                     }
5702                 } elsif ($state =~ m{^(name|prereq)$}) {
5703                     if (/^=/) {
5704                         $state = "poddir";
5705                     } elsif (/^\s*$/) {
5706                         # nop
5707                     } elsif ($state eq "name") {
5708                         if ($name eq "") {
5709                             ($name) = /^(\S+)/;
5710                             $state = "poddir";
5711                         }
5712                     } elsif ($state eq "prereq") {
5713                         $prereq .= $_;
5714                     }
5715                 } elsif (/^=cut\b/) {
5716                     last;
5717                 }
5718             }
5719             $fh->close;
5720
5721             for ($name) {
5722                 s{.*<}{};       # strip X<...>
5723                 s{>.*}{};
5724             }
5725             chomp $prereq;
5726             $prereq = join " ", split /\s+/, $prereq;
5727             my($PREREQ_PM) = join("\n", map {
5728                 s{.*<}{};       # strip X<...>
5729                 s{>.*}{};
5730                 if (/[\s\'\"]/) { # prose?
5731                 } else {
5732                     s/[^\w:]$//; # period?
5733                     " "x28 . "'$_' => 0,";
5734                 }
5735             } split /\s*,\s*/, $prereq);
5736
5737             $script = "
5738               EXE_FILES => ['$name'],
5739               PREREQ_PM => {
5740 $PREREQ_PM
5741                            },
5742 ";
5743             if ($name) {
5744                 my $to_file = File::Spec->catfile($packagedir, $name);
5745                 rename $script_file, $to_file
5746                     or die "Can't rename $script_file to $to_file: $!";
5747             }
5748         }
5749
5750         my $fh = FileHandle->new;
5751         $fh->open(">$mpl")
5752             or Carp::croak("Could not open >$mpl: $!");
5753         $fh->print(
5754                    qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
5755 # because there was no Makefile.PL supplied.
5756 # Autogenerated on: }.scalar localtime().qq{
5757
5758 use ExtUtils::MakeMaker;
5759 WriteMakefile(
5760               NAME => q[$cf],$script
5761              );
5762 });
5763         $fh->close;
5764     }
5765 }
5766
5767 #-> CPAN::Distribution::_signature_business
5768 sub _signature_business {
5769     my($self) = @_;
5770     my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
5771                                                       q{check_sigs});
5772     if ($check_sigs) {
5773         if ($CPAN::META->has_inst("Module::Signature")) {
5774             if (-f "SIGNATURE") {
5775                 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
5776                 my $rv = Module::Signature::verify();
5777                 if ($rv != Module::Signature::SIGNATURE_OK() and
5778                     $rv != Module::Signature::SIGNATURE_MISSING()) {
5779                     $CPAN::Frontend->mywarn(
5780                                             qq{\nSignature invalid for }.
5781                                             qq{distribution file. }.
5782                                             qq{Please investigate.\n\n}
5783                                            );
5784
5785                     my $wrap =
5786                         sprintf(qq{I'd recommend removing %s. Its signature
5787 is invalid. Maybe you have configured your 'urllist' with
5788 a bad URL. Please check this array with 'o conf urllist', and
5789 retry. For more information, try opening a subshell with
5790   look %s
5791 and there run
5792   cpansign -v
5793 },
5794                                 $self->{localfile},
5795                                 $self->pretty_id,
5796                                );
5797                     $self->{signature_verify} = CPAN::Distrostatus->new("NO");
5798                     $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
5799                     $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
5800                 } else {
5801                     $self->{signature_verify} = CPAN::Distrostatus->new("YES");
5802                     $self->debug("Module::Signature has verified") if $CPAN::DEBUG;
5803                 }
5804             } else {
5805                 $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n});
5806             }
5807         } else {
5808             $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
5809         }
5810     }
5811 }
5812
5813 #-> CPAN::Distribution::untar_me ;
5814 sub untar_me {
5815     my($self,$ct) = @_;
5816     $self->{archived} = "tar";
5817     if ($ct->untar()) {
5818         $self->{unwrapped} = CPAN::Distrostatus->new("YES");
5819     } else {
5820         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed");
5821     }
5822 }
5823
5824 # CPAN::Distribution::unzip_me ;
5825 sub unzip_me {
5826     my($self,$ct) = @_;
5827     $self->{archived} = "zip";
5828     if ($ct->unzip()) {
5829         $self->{unwrapped} = CPAN::Distrostatus->new("YES");
5830     } else {
5831         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed");
5832     }
5833     return;
5834 }
5835
5836 sub handle_singlefile {
5837     my($self,$local_file) = @_;
5838
5839     if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ){
5840         $self->{archived} = "pm";
5841     } else {
5842         $self->{archived} = "maybe_pl";
5843     }
5844
5845     my $to = File::Basename::basename($local_file);
5846     if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
5847         if (eval{CPAN::Tarzip->new($local_file)->gunzip($to)}) {
5848             $self->{unwrapped} = CPAN::Distrostatus->new("YES");
5849         } else {
5850             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- uncompressing failed");
5851         }
5852     } else {
5853         File::Copy::cp($local_file,".");
5854         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed");
5855     }
5856     return $to;
5857 }
5858
5859 #-> sub CPAN::Distribution::new ;
5860 sub new {
5861     my($class,%att) = @_;
5862
5863     # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
5864
5865     my $this = { %att };
5866     return bless $this, $class;
5867 }
5868
5869 #-> sub CPAN::Distribution::look ;
5870 sub look {
5871     my($self) = @_;
5872
5873     if ($^O eq 'MacOS') {
5874       $self->Mac::BuildTools::look;
5875       return;
5876     }
5877
5878     if (  $CPAN::Config->{'shell'} ) {
5879         $CPAN::Frontend->myprint(qq{
5880 Trying to open a subshell in the build directory...
5881 });
5882     } else {
5883         $CPAN::Frontend->myprint(qq{
5884 Your configuration does not define a value for subshells.
5885 Please define it with "o conf shell <your shell>"
5886 });
5887         return;
5888     }
5889     my $dist = $self->id;
5890     my $dir;
5891     unless ($dir = $self->dir) {
5892         $self->get;
5893     }
5894     unless ($dir ||= $self->dir) {
5895         $CPAN::Frontend->mywarn(qq{
5896 Could not determine which directory to use for looking at $dist.
5897 });
5898         return;
5899     }
5900     my $pwd  = CPAN::anycwd();
5901     $self->safe_chdir($dir);
5902     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
5903     {
5904         local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
5905         $ENV{CPAN_SHELL_LEVEL} += 1;
5906         my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'});
5907         unless (system($shell) == 0) {
5908             my $code = $? >> 8;
5909             $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
5910         }
5911     }
5912     $self->safe_chdir($pwd);
5913 }
5914
5915 # CPAN::Distribution::cvs_import ;
5916 sub cvs_import {
5917     my($self) = @_;
5918     $self->get;
5919     my $dir = $self->dir;
5920
5921     my $package = $self->called_for;
5922     my $module = $CPAN::META->instance('CPAN::Module', $package);
5923     my $version = $module->cpan_version;
5924
5925     my $userid = $self->cpan_userid;
5926
5927     my $cvs_dir = (split /\//, $dir)[-1];
5928     $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
5929     my $cvs_root =
5930       $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
5931     my $cvs_site_perl =
5932       $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
5933     if ($cvs_site_perl) {
5934         $cvs_dir = "$cvs_site_perl/$cvs_dir";
5935     }
5936     my $cvs_log = qq{"imported $package $version sources"};
5937     $version =~ s/\./_/g;
5938     # XXX cvs: undocumented and unclear how it was meant to work
5939     my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
5940                "$cvs_dir", $userid, "v$version");
5941
5942     my $pwd  = CPAN::anycwd();
5943     chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
5944
5945     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
5946
5947     $CPAN::Frontend->myprint(qq{@cmd\n});
5948     system(@cmd) == 0 or
5949     # XXX cvs
5950         $CPAN::Frontend->mydie("cvs import failed");
5951     chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
5952 }
5953
5954 #-> sub CPAN::Distribution::readme ;
5955 sub readme {
5956     my($self) = @_;
5957     my($dist) = $self->id;
5958     my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
5959     $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
5960     my($local_file);
5961     my($local_wanted) =
5962          File::Spec->catfile(
5963                              $CPAN::Config->{keep_source_where},
5964                              "authors",
5965                              "id",
5966                              split(/\//,"$sans.readme"),
5967                             );
5968     $self->debug("Doing localize") if $CPAN::DEBUG;
5969     $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
5970                                       $local_wanted)
5971         or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
5972
5973     if ($^O eq 'MacOS') {
5974         Mac::BuildTools::launch_file($local_file);
5975         return;
5976     }
5977
5978     my $fh_pager = FileHandle->new;
5979     local($SIG{PIPE}) = "IGNORE";
5980     my $pager = $CPAN::Config->{'pager'} || "cat";
5981     $fh_pager->open("|$pager")
5982         or die "Could not open pager $pager\: $!";
5983     my $fh_readme = FileHandle->new;
5984     $fh_readme->open($local_file)
5985         or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
5986     $CPAN::Frontend->myprint(qq{
5987 Displaying file
5988   $local_file
5989 with pager "$pager"
5990 });
5991     $fh_pager->print(<$fh_readme>);
5992     $fh_pager->close;
5993 }
5994
5995 #-> sub CPAN::Distribution::verifyCHECKSUM ;
5996 sub verifyCHECKSUM {
5997     my($self) = @_;
5998   EXCUSE: {
5999         my @e;
6000         $self->{CHECKSUM_STATUS} ||= "";
6001         $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
6002         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
6003     }
6004     my($lc_want,$lc_file,@local,$basename);
6005     @local = split(/\//,$self->id);
6006     pop @local;
6007     push @local, "CHECKSUMS";
6008     $lc_want =
6009         File::Spec->catfile($CPAN::Config->{keep_source_where},
6010                             "authors", "id", @local);
6011     local($") = "/";
6012     if (my $size = -s $lc_want) {
6013         $self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG;
6014         if ($self->CHECKSUM_check_file($lc_want,1)) {
6015             return $self->{CHECKSUM_STATUS} = "OK";
6016         }
6017     }
6018     $lc_file = CPAN::FTP->localize("authors/id/@local",
6019                                    $lc_want,1);
6020     unless ($lc_file) {
6021         $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
6022         $local[-1] .= ".gz";
6023         $lc_file = CPAN::FTP->localize("authors/id/@local",
6024                                        "$lc_want.gz",1);
6025         if ($lc_file) {
6026             $lc_file =~ s/\.gz(?!\n)\Z//;
6027             eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
6028         } else {
6029             return;
6030         }
6031     }
6032     if ($self->CHECKSUM_check_file($lc_file)) {
6033         return $self->{CHECKSUM_STATUS} = "OK";
6034     }
6035 }
6036
6037 #-> sub CPAN::Distribution::SIG_check_file ;
6038 sub SIG_check_file {
6039     my($self,$chk_file) = @_;
6040     my $rv = eval { Module::Signature::_verify($chk_file) };
6041
6042     if ($rv == Module::Signature::SIGNATURE_OK()) {
6043         $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
6044         return $self->{SIG_STATUS} = "OK";
6045     } else {
6046         $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
6047                                  qq{distribution file. }.
6048                                  qq{Please investigate.\n\n}.
6049                                  $self->as_string,
6050                                 $CPAN::META->instance(
6051                                                         'CPAN::Author',
6052                                                         $self->cpan_userid
6053                                                         )->as_string);
6054
6055         my $wrap = qq{I\'d recommend removing $chk_file. Its signature
6056 is invalid. Maybe you have configured your 'urllist' with
6057 a bad URL. Please check this array with 'o conf urllist', and
6058 retry.};
6059
6060         $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
6061     }
6062 }
6063
6064 #-> sub CPAN::Distribution::CHECKSUM_check_file ;
6065
6066 # sloppy is 1 when we have an old checksums file that maybe is good
6067 # enough
6068
6069 sub CHECKSUM_check_file {
6070     my($self,$chk_file,$sloppy) = @_;
6071     my($cksum,$file,$basename);
6072
6073     $sloppy ||= 0;
6074     $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG;
6075     my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
6076                                                       q{check_sigs});
6077     if ($check_sigs) {
6078         if ($CPAN::META->has_inst("Module::Signature")) {
6079             $self->debug("Module::Signature is installed, verifying");
6080             $self->SIG_check_file($chk_file);
6081         } else {
6082             $self->debug("Module::Signature is NOT installed");
6083         }
6084     }
6085
6086     $file = $self->{localfile};
6087     $basename = File::Basename::basename($file);
6088     my $fh = FileHandle->new;
6089     if (open $fh, $chk_file){
6090         local($/);
6091         my $eval = <$fh>;
6092         $eval =~ s/\015?\012/\n/g;
6093         close $fh;
6094         my($comp) = Safe->new();
6095         $cksum = $comp->reval($eval);
6096         if ($@) {
6097             rename $chk_file, "$chk_file.bad";
6098             Carp::confess($@) if $@;
6099         }
6100     } else {
6101         Carp::carp "Could not open $chk_file for reading";
6102     }
6103
6104     if (! ref $cksum or ref $cksum ne "HASH") {
6105         $CPAN::Frontend->mywarn(qq{
6106 Warning: checksum file '$chk_file' broken.
6107
6108 When trying to read that file I expected to get a hash reference
6109 for further processing, but got garbage instead.
6110 });
6111         my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
6112         $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
6113         $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken";
6114         return;
6115     } elsif (exists $cksum->{$basename}{sha256}) {
6116         $self->debug("Found checksum for $basename:" .
6117                      "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
6118
6119         open($fh, $file);
6120         binmode $fh;
6121         my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
6122         $fh->close;
6123         $fh = CPAN::Tarzip->TIEHANDLE($file);
6124
6125         unless ($eq) {
6126           my $dg = Digest::SHA->new(256);
6127           my($data,$ref);
6128           $ref = \$data;
6129           while ($fh->READ($ref, 4096) > 0){
6130             $dg->add($data);
6131           }
6132           my $hexdigest = $dg->hexdigest;
6133           $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
6134         }
6135
6136         if ($eq) {
6137           $CPAN::Frontend->myprint("Checksum for $file ok\n");
6138           return $self->{CHECKSUM_STATUS} = "OK";
6139         } else {
6140             $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
6141                                      qq{distribution file. }.
6142                                      qq{Please investigate.\n\n}.
6143                                      $self->as_string,
6144                                      $CPAN::META->instance(
6145                                                            'CPAN::Author',
6146                                                            $self->cpan_userid
6147                                                           )->as_string);
6148
6149             my $wrap = qq{I\'d recommend removing $file. Its
6150 checksum is incorrect. Maybe you have configured your 'urllist' with
6151 a bad URL. Please check this array with 'o conf urllist', and
6152 retry.};
6153
6154             $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
6155
6156             # former versions just returned here but this seems a
6157             # serious threat that deserves a die
6158
6159             # $CPAN::Frontend->myprint("\n\n");
6160             # sleep 3;
6161             # return;
6162         }
6163         # close $fh if fileno($fh);
6164     } else {
6165         return if $sloppy;
6166         unless ($self->{CHECKSUM_STATUS}) {
6167             $CPAN::Frontend->mywarn(qq{
6168 Warning: No checksum for $basename in $chk_file.
6169
6170 The cause for this may be that the file is very new and the checksum
6171 has not yet been calculated, but it may also be that something is
6172 going awry right now.
6173 });
6174             my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes");
6175             $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
6176         }
6177         $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file";
6178         return;
6179     }
6180 }
6181
6182 #-> sub CPAN::Distribution::eq_CHECKSUM ;
6183 sub eq_CHECKSUM {
6184     my($self,$fh,$expect) = @_;
6185     if ($CPAN::META->has_inst("Digest::SHA")) {
6186         my $dg = Digest::SHA->new(256);
6187         my($data);
6188         while (read($fh, $data, 4096)){
6189             $dg->add($data);
6190         }
6191         my $hexdigest = $dg->hexdigest;
6192         # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
6193         return $hexdigest eq $expect;
6194     }
6195     return 1;
6196 }
6197
6198 #-> sub CPAN::Distribution::force ;
6199
6200 # Both CPAN::Modules and CPAN::Distributions know if "force" is in
6201 # effect by autoinspection, not by inspecting a global variable. One
6202 # of the reason why this was chosen to work that way was the treatment
6203 # of dependencies. They should not automatically inherit the force
6204 # status. But this has the downside that ^C and die() will return to
6205 # the prompt but will not be able to reset the force_update
6206 # attributes. We try to correct for it currently in the read_metadata
6207 # routine, and immediately before we check for a Signal. I hope this
6208 # works out in one of v1.57_53ff
6209
6210 # "Force get forgets previous error conditions"
6211
6212 #-> sub CPAN::Distribution::force ;
6213 sub force {
6214   my($self, $method) = @_;
6215   for my $att (qw(
6216                   CHECKSUM_STATUS
6217                   archived
6218                   badtestcnt
6219                   build_dir
6220                   install
6221                   localfile
6222                   make
6223                   make_test
6224                   modulebuild
6225                   prefs
6226                   prefs_file
6227                   prereq_pm
6228                   prereq_pm_detected
6229                   reqtype
6230                   signature_verify
6231                   unwrapped
6232                   writemakefile
6233                   yaml_content
6234  )) {
6235     delete $self->{$att};
6236     CPAN->debug(sprintf "att[%s]", $att) if $CPAN::DEBUG;
6237   }
6238   if ($method && $method =~ /make|test|install/) {
6239     $self->{"force_update"}++; # name should probably have been force_install
6240   }
6241 }
6242
6243 #-> sub CPAN::Distribution::notest ;
6244 sub notest {
6245   my($self, $method) = @_;
6246   # warn "XDEBUG: set notest for $self $method";
6247   $self->{"notest"}++; # name should probably have been force_install
6248 }
6249
6250 #-> sub CPAN::Distribution::unnotest ;
6251 sub unnotest {
6252   my($self) = @_;
6253   # warn "XDEBUG: deleting notest";
6254   delete $self->{'notest'};
6255 }
6256
6257 #-> sub CPAN::Distribution::unforce ;
6258 sub unforce {
6259   my($self) = @_;
6260   delete $self->{'force_update'};
6261 }
6262
6263 #-> sub CPAN::Distribution::isa_perl ;
6264 sub isa_perl {
6265   my($self) = @_;
6266   my $file = File::Basename::basename($self->id);
6267   if ($file =~ m{ ^ perl
6268                   -?
6269                   (5)
6270                   ([._-])
6271                   (
6272                    \d{3}(_[0-4][0-9])?
6273                    |
6274                    \d+\.\d+
6275                   )
6276                   \.tar[._-](?:gz|bz2)
6277                   (?!\n)\Z
6278                 }xs){
6279     return "$1.$3";
6280   } elsif ($self->cpan_comment
6281            &&
6282            $self->cpan_comment =~ /isa_perl\(.+?\)/){
6283     return $1;
6284   }
6285 }
6286
6287
6288 #-> sub CPAN::Distribution::perl ;
6289 sub perl {
6290     my ($self) = @_;
6291     if (! $self) {
6292         use Carp qw(carp);
6293         carp __PACKAGE__ . "::perl was called without parameters.";
6294     }
6295     return CPAN::HandleConfig->safe_quote($CPAN::Perl);
6296 }
6297
6298
6299 #-> sub CPAN::Distribution::make ;
6300 sub make {
6301     my($self) = @_;
6302     if (my $goto = $self->prefs->{goto}) {
6303         return $self->goto($goto);
6304     }
6305     my $make = $self->{modulebuild} ? "Build" : "make";
6306     # Emergency brake if they said install Pippi and get newest perl
6307     if ($self->isa_perl) {
6308       if (
6309           $self->called_for ne $self->id &&
6310           ! $self->{force_update}
6311          ) {
6312         # if we die here, we break bundles
6313         $CPAN::Frontend
6314             ->mywarn(sprintf(
6315                              qq{The most recent version "%s" of the module "%s"
6316 is part of the perl-%s distribution. To install that, you need to run
6317   force install %s   --or--
6318   install %s
6319 },
6320                              $CPAN::META->instance(
6321                                                    'CPAN::Module',
6322                                                    $self->called_for
6323                                                   )->cpan_version,
6324                              $self->called_for,
6325                              $self->isa_perl,
6326                              $self->called_for,
6327                              $self->id,
6328                             ));
6329         $self->{make} = CPAN::Distrostatus->new("NO isa perl");
6330         $CPAN::Frontend->mysleep(1);
6331         return;
6332       }
6333     }
6334     $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
6335     $self->get;
6336     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
6337                            ? $ENV{PERL5LIB}
6338                            : ($ENV{PERLLIB} || "");
6339
6340     $CPAN::META->set_perl5lib;
6341     local $ENV{MAKEFLAGS}; # protect us from outer make calls
6342
6343     if ($CPAN::Signal){
6344       delete $self->{force_update};
6345       return;
6346     }
6347   EXCUSE: {
6348         my @e;
6349         if (!$self->{archived} || $self->{archived} eq "NO") {
6350             push @e, "Is neither a tar nor a zip archive.";
6351         }
6352
6353         if (!$self->{unwrapped}
6354             || (
6355                 UNIVERSAL::can($self->{unwrapped},"failed") ?
6356                 $self->{unwrapped}->failed :
6357                 $self->{unwrapped} =~ /^NO/
6358                )) {
6359             push @e, "Had problems unarchiving. Please build manually";
6360         }
6361
6362         unless ($self->{force_update}) {
6363             exists $self->{signature_verify} and
6364                 (
6365                  UNIVERSAL::can($self->{signature_verify},"failed") ?
6366                  $self->{signature_verify}->failed :
6367                  $self->{signature_verify} =~ /^NO/
6368                 )
6369                 and push @e, "Did not pass the signature test.";
6370         }
6371
6372         if (exists $self->{writemakefile} &&
6373             (
6374              UNIVERSAL::can($self->{writemakefile},"failed") ?
6375              $self->{writemakefile}->failed :
6376              $self->{writemakefile} =~ /^NO/
6377             )) {
6378             # XXX maybe a retry would be in order?
6379             my $err = UNIVERSAL::can($self->{writemakefile},"text") ?
6380                 $self->{writemakefile}->text :
6381                     $self->{writemakefile};
6382             $err =~ s/^NO\s*//;
6383             $err ||= "Had some problem writing Makefile";
6384             $err .= ", won't make";
6385             push @e, $err;
6386         }
6387
6388         defined $self->{make} and push @e,
6389             "Has already been processed within this session";
6390
6391         if (exists $self->{later} and length($self->{later})) {
6392             if ($self->unsat_prereq) {
6393                 push @e, $self->{later};
6394 # RT ticket 18438 raises doubts if the deletion of {later} is valid.
6395 # YAML-0.53 triggered the later hodge-podge here, but my margin notes
6396 # are not sufficient to be sure if we really must/may do the delete
6397 # here. SO I accept the suggested patch for now. If we trigger a bug
6398 # again, I must go into deep contemplation about the {later} flag.
6399
6400 #            } else {
6401 #                delete $self->{later};
6402             }
6403         }
6404
6405         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
6406     }
6407     if ($CPAN::Signal){
6408       delete $self->{force_update};
6409       return;
6410     }
6411     $CPAN::Frontend->myprint("\n  CPAN.pm: Going to build ".$self->id."\n\n");
6412     my $builddir = $self->dir or
6413         $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
6414     chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
6415     $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
6416
6417     if ($^O eq 'MacOS') {
6418         Mac::BuildTools::make($self);
6419         return;
6420     }
6421
6422     my $system;
6423     if ($self->{'configure'}) {
6424         $system = $self->{'configure'};
6425     } elsif ($self->{modulebuild}) {
6426         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
6427         $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}";
6428     } else {
6429         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
6430         my $switch = "";
6431 # This needs a handler that can be turned on or off:
6432 #       $switch = "-MExtUtils::MakeMaker ".
6433 #           "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
6434 #           if $] > 5.00310;
6435         my $makepl_arg = $self->make_x_arg("pl");
6436         $system = sprintf("%s%s Makefile.PL%s",
6437                           $perl,
6438                           $switch ? " $switch" : "",
6439                           $makepl_arg ? " $makepl_arg" : "",
6440                          );
6441     }
6442     my %env;
6443     while (my($k,$v) = each %ENV) {
6444         next unless defined $v;
6445         $env{$k} = $v;
6446     }
6447     local %ENV = %env;
6448     if (my $env = $self->prefs->{pl}{env}) {
6449         for my $e (keys %$env) {
6450             $ENV{$e} = $env->{$e};
6451         }
6452     }
6453     if (exists $self->{writemakefile}) {
6454     } else {
6455         local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
6456         my($ret,$pid);
6457         $@ = "";
6458         my $go_via_alarm;
6459         if ($CPAN::Config->{inactivity_timeout}) {
6460             require Config;
6461             if ($Config::Config{d_alarm}
6462                 &&
6463                 $Config::Config{d_alarm} eq "define"
6464                ) {
6465                 $go_via_alarm++
6466             } else {
6467                 $CPAN::Frontend->mywarn("Warning: you have configured the config ".
6468                                         "variable 'inactivity_timeout' to ".
6469                                         "'$CPAN::Config->{inactivity_timeout}'. But ".
6470                                         "on this machine the system call 'alarm' ".
6471                                         "isn't available. This means that we cannot ".
6472                                         "provide the feature of intercepting long ".
6473                                         "waiting code and will turn this feature off.\n"
6474                                        );
6475                 $CPAN::Config->{inactivity_timeout} = 0;
6476             }
6477         }
6478         if ($go_via_alarm) {
6479             eval {
6480                 alarm $CPAN::Config->{inactivity_timeout};
6481                 local $SIG{CHLD}; # = sub { wait };
6482                 if (defined($pid = fork)) {
6483                     if ($pid) { #parent
6484                         # wait;
6485                         waitpid $pid, 0;
6486                     } else {    #child
6487                         # note, this exec isn't necessary if
6488                         # inactivity_timeout is 0. On the Mac I'd
6489                         # suggest, we set it always to 0.
6490                         exec $system;
6491                     }
6492                 } else {
6493                     $CPAN::Frontend->myprint("Cannot fork: $!");
6494                     return;
6495                 }
6496             };
6497             alarm 0;
6498             if ($@){
6499                 kill 9, $pid;
6500                 waitpid $pid, 0;
6501                 my $err = "$@";
6502                 $CPAN::Frontend->myprint($err);
6503                 $self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
6504                 $@ = "";
6505                 return;
6506             }
6507         } else {
6508             if (my $expect_model = $self->_prefs_with_expect("pl")) {
6509                 $ret = $self->_run_via_expect($system,$expect_model);
6510                 if (! defined $ret
6511                     && $self->{writemakefile}
6512                     && $self->{writemakefile}->failed) {
6513                     # timeout
6514                     return;
6515                 }
6516             } else {
6517                 $ret = system($system);
6518             }
6519             if ($ret != 0) {
6520                 $self->{writemakefile} = CPAN::Distrostatus
6521                     ->new("NO '$system' returned status $ret");
6522                 $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
6523                 $self->store_persistent_state;
6524                 $self->store_persistent_state;
6525                 return;
6526             }
6527         }
6528         if (-f "Makefile" || -f "Build") {
6529           $self->{writemakefile} = CPAN::Distrostatus->new("YES");
6530           delete $self->{make_clean}; # if cleaned before, enable next
6531         } else {
6532           $self->{writemakefile} = CPAN::Distrostatus
6533               ->new(qq{NO -- Unknown reason});
6534         }
6535     }
6536     if ($CPAN::Signal){
6537       delete $self->{force_update};
6538       return;
6539     }
6540     if (my @prereq = $self->unsat_prereq){
6541         if ($prereq[0][0] eq "perl") {
6542             my $need = "requires perl '$prereq[0][1]'";
6543             my $id = $self->pretty_id;
6544             $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
6545             $self->{make} = CPAN::Distrostatus->new("NO $need");
6546             $self->store_persistent_state;
6547             return;
6548         } else {
6549             return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
6550         }
6551     }
6552     if ($CPAN::Signal){
6553       delete $self->{force_update};
6554       return;
6555     }
6556     if ($self->{modulebuild}) {
6557         unless (-f "Build") {
6558             my $cwd = Cwd::cwd;
6559             $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
6560                                     " in cwd[$cwd]. Danger, Will Robinson!");
6561             $CPAN::Frontend->mysleep(5);
6562         }
6563         $system = sprintf "%s %s", $self->_build_command(), $CPAN::Config->{mbuild_arg};
6564     } else {
6565         $system = join " ", $self->_make_command(), $CPAN::Config->{make_arg};
6566     }
6567     my $make_arg = $self->make_x_arg("make");
6568     $system = sprintf("%s%s",
6569                       $system,
6570                       $make_arg ? " $make_arg" : "",
6571                      );
6572     if (my $env = $self->prefs->{make}{env}) { # overriding the local
6573                                                # ENV of PL, not the
6574                                                # outer ENV, but
6575                                                # unlikely to be a risk
6576         for my $e (keys %$env) {
6577             $ENV{$e} = $env->{$e};
6578         }
6579     }
6580     my $expect_model = $self->_prefs_with_expect("make");
6581     my $want_expect = 0;
6582     if ( $expect_model && @{$expect_model->{talk}} ) {
6583         my $can_expect = $CPAN::META->has_inst("Expect");
6584         if ($can_expect) {
6585             $want_expect = 1;
6586         } else {
6587             $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
6588                                     "system()\n");
6589         }
6590     }
6591     my $system_ok;
6592     if ($want_expect) {
6593         $system_ok = $self->_run_via_expect($system,$expect_model) == 0;
6594     } else {
6595         $system_ok = system($system) == 0;
6596     }
6597     $self->introduce_myself;
6598     if ( $system_ok ) {
6599          $CPAN::Frontend->myprint("  $system -- OK\n");
6600          $self->{make} = CPAN::Distrostatus->new("YES");
6601     } else {
6602          $self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
6603          $self->{make} = CPAN::Distrostatus->new("NO");
6604          $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
6605     }
6606     $self->store_persistent_state;
6607 }
6608
6609 # CPAN::Distribution::_run_via_expect
6610 sub _run_via_expect {
6611     my($self,$system,$expect_model) = @_;
6612     CPAN->debug("system[$system]expect_model[$expect_model]") if $CPAN::DEBUG;
6613     if ($CPAN::META->has_inst("Expect")) {
6614         my $expo = Expect->new;  # expo Expect object;
6615         $expo->spawn($system);
6616         my $expecta = $expect_model->{talk};
6617         if ($expect_model->{mode} eq "expect") {
6618             return $self->_run_via_expect_deterministic($expo,$expecta);
6619         } elsif ($expect_model->{mode} eq "expect-in-any-order") {
6620             return $self->_run_via_expect_anyorder($expo,$expecta);
6621         } else {
6622             die "Panic: Illegal expect mode: $expect_model->{mode}";
6623         }
6624     } else {
6625         $CPAN::Frontend->mywarn("Expect not installed, falling back to system()\n");
6626         return system($system);
6627     }
6628 }
6629
6630 sub _run_via_expect_anyorder {
6631     my($self,$expo,$expecta) = @_;
6632     my $timeout = 3; # currently unsettable
6633     my @expectacopy = @$expecta; # we trash it!
6634     my $but = "";
6635   EXPECT: while () {
6636         my($eof,$ran_into_timeout);
6637         my @match = $expo->expect($timeout,
6638                                   [ eof => sub {
6639                                         $eof++;
6640                                     } ],
6641                                   [ timeout => sub {
6642                                         $ran_into_timeout++;
6643                                     } ],
6644                                   -re => eval"qr{.}",
6645                                  );
6646         if ($match[2]) {
6647             $but .= $match[2];
6648         }
6649         $but .= $expo->clear_accum;
6650         if ($eof) {
6651             $expo->soft_close;
6652             return $expo->exitstatus();
6653         } elsif ($ran_into_timeout) {
6654             # warn "DEBUG: they are asking a question, but[$but]";
6655             for (my $i = 0; $i <= $#expectacopy; $i+=2) {
6656                 my($next,$send) = @expectacopy[$i,$i+1];
6657                 my $regex = eval "qr{$next}";
6658                 # warn "DEBUG: will compare with regex[$regex].";
6659                 if ($but =~ /$regex/) {
6660                     # warn "DEBUG: will send send[$send]";
6661                     $expo->send($send);
6662                     splice @expectacopy, $i, 2; # never allow reusing an QA pair
6663                     next EXPECT;
6664                 }
6665             }
6666             my $why = "could not answer a question during the dialog";
6667             $CPAN::Frontend->mywarn("Failing: $why\n");
6668             $self->{writemakefile} =
6669                 CPAN::Distrostatus->new("NO $why");
6670             return;
6671         }
6672     }
6673 }
6674
6675 sub _run_via_expect_deterministic {
6676     my($self,$expo,$expecta) = @_;
6677     my $ran_into_timeout;
6678   EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) {
6679         my($next,$send) = @$expecta[$i,$i+1];
6680         my($timeout,$re);
6681         if (ref $next) {
6682             $timeout = $next->{timeout};
6683             $re = $next->{expect};
6684         } else {
6685             $timeout = 15;
6686             $re = $next;
6687         }
6688         CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG;
6689         my $regex = eval "qr{$re}";
6690         $expo->expect($timeout,
6691                       [ eof => sub {
6692                             my $but = $expo->clear_accum;
6693                             $CPAN::Frontend->mywarn("EOF (maybe harmless)
6694 expected[$regex]\nbut[$but]\n\n");
6695                             last EXPECT;
6696                         } ],
6697                       [ timeout => sub {
6698                             my $but = $expo->clear_accum;
6699                             $CPAN::Frontend->mywarn("TIMEOUT
6700 expected[$regex]\nbut[$but]\n\n");
6701                             $ran_into_timeout++;
6702                         } ],
6703                       -re => $regex);
6704         if ($ran_into_timeout){
6705             # note that the caller expects 0 for success
6706             $self->{writemakefile} =
6707                 CPAN::Distrostatus->new("NO timeout during expect dialog");
6708             return;
6709         }
6710         $expo->send($send);
6711     }
6712     $expo->soft_close;
6713     return $expo->exitstatus();
6714 }
6715
6716 # CPAN::Distribution::_find_prefs
6717 sub _find_prefs {
6718     my($self) = @_;
6719     my $distroid = $self->pretty_id;
6720     CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG;
6721     my $prefs_dir = $CPAN::Config->{prefs_dir};
6722     eval { File::Path::mkpath($prefs_dir); };
6723     if ($@) {
6724         $CPAN::Frontend->mydie("Cannot create directory $prefs_dir");
6725     }
6726     my $yaml_module = CPAN->_yaml_module;
6727     my @extensions;
6728     if ($CPAN::META->has_inst($yaml_module)) {
6729         push @extensions, "yml";
6730     } else {
6731         my @fallbacks;
6732         if ($CPAN::META->has_inst("Data::Dumper")) {
6733             push @extensions, "dd";
6734             push @fallbacks, "Data::Dumper";
6735         }
6736         if ($CPAN::META->has_inst("Storable")) {
6737             push @extensions, "st";
6738             push @fallbacks, "Storable";
6739         }
6740         if (@fallbacks) {
6741             local $" = " and ";
6742             unless ($self->{have_complained_about_missing_yaml}++) {
6743                 $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back ".
6744                                         "to @fallbacks to read prefs '$prefs_dir'\n");
6745             }
6746         } else {
6747             unless ($self->{have_complained_about_missing_yaml}++) {
6748                 $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot ".
6749                                         "read prefs '$prefs_dir'\n");
6750             }
6751         }
6752     }
6753     if (@extensions) {
6754         my $dh = DirHandle->new($prefs_dir)
6755             or die Carp::croak("Couldn't open '$prefs_dir': $!");
6756       DIRENT: for (sort $dh->read) {
6757             next if $_ eq "." || $_ eq "..";
6758             my $exte = join "|", @extensions;
6759             next unless /\.($exte)$/;
6760             my $thisexte = $1;
6761             my $abs = File::Spec->catfile($prefs_dir, $_);
6762             if (-f $abs) {
6763                 CPAN->debug(sprintf "abs[%s]", $abs) if $CPAN::DEBUG;
6764                 my @distropref;
6765                 if ($thisexte eq "yml") {
6766                     @distropref = @{CPAN->_yaml_loadfile($abs)};
6767                 } elsif ($thisexte eq "dd") {
6768                     package CPAN::Eval;
6769                     no strict;
6770                     open FH, "<$abs" or $CPAN::Frontend->mydie("Could not open '$abs': $!");
6771                     local $/;
6772                     my $eval = <FH>;
6773                     close FH;
6774                     eval $eval;
6775                     if ($@) {
6776                         $CPAN::Frontend->mydie("Error in distroprefs file $_\: $@");
6777                     }
6778                     my $i = 1;
6779                     while (${"VAR".$i}) {
6780                         push @distropref, ${"VAR".$i};
6781                         $i++;
6782                     }
6783                 } elsif ($thisexte eq "st") {
6784                     # eval because Storable is never forward compatible
6785                     eval { @distropref = @{scalar Storable::retrieve($abs)}; };
6786                     if ($@) {
6787                         $CPAN::Frontend->mywarn("Error reading distroprefs file ".
6788                                                 "$_, skipping\: $@");
6789                         $CPAN::Frontend->mysleep(4);
6790                         next DIRENT;
6791                     }
6792                 }
6793                 # $DB::single=1;
6794               ELEMENT: for my $y (0..$#distropref) {
6795                     my $distropref = $distropref[$y];
6796                     my $match = $distropref->{match};
6797                     unless ($match) {
6798                         CPAN->debug("no 'match' in abs[$abs], skipping");
6799                         next ELEMENT;
6800                     }
6801                     my $ok = 1;
6802                     for my $sub_attribute (keys %$match) {
6803                         my $qr = eval "qr{$distropref->{match}{$sub_attribute}}";
6804                         if ($sub_attribute eq "module") {
6805                             my $okm = 0;
6806                             CPAN->debug(sprintf "abs[%s]distropref[%d]", $abs, scalar @distropref) if $CPAN::DEBUG;
6807                             my @modules = $self->containsmods;
6808                             CPAN->debug(sprintf "abs[%s]distropref[%d]modules[%s]", $abs, scalar @distropref, join(",",@modules)) if $CPAN::DEBUG;
6809                           MODULE: for my $module (@modules) {
6810                                 $okm ||= $module =~ /$qr/;
6811                                 last MODULE if $okm;
6812                             }
6813                             $ok &&= $okm;
6814                         } elsif ($sub_attribute eq "distribution") {
6815                             my $okd = $distroid =~ /$qr/;
6816                             $ok &&= $okd;
6817                         } elsif ($sub_attribute eq "perl") {
6818                             my $okp = $^X =~ /$qr/;
6819                             $ok &&= $okp;
6820                         } else {
6821                             $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ".
6822                                                    "unknown sub_attribut '$sub_attribute'. ".
6823                                                    "Please ".
6824                                                    "remove, cannot continue.");
6825                         }
6826                     }
6827                     CPAN->debug(sprintf "abs[%s]distropref[%d]ok[%d]", $abs, scalar @distropref, $ok) if $CPAN::DEBUG;
6828                     if ($ok) {
6829                         return {
6830                                 prefs => $distropref,
6831                                 prefs_file => $abs,
6832                                 prefs_file_doc => $y,
6833                                };
6834                     }
6835
6836                 }
6837             }
6838         }
6839     }
6840     return;
6841 }
6842
6843 # CPAN::Distribution::prefs
6844 sub prefs {
6845     my($self) = @_;
6846     if (exists $self->{prefs}) {
6847         return $self->{prefs}; # XXX comment out during debugging
6848     }
6849     if ($CPAN::Config->{prefs_dir}) {
6850         CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG;
6851         my $prefs = $self->_find_prefs();
6852         if ($prefs) {
6853             for my $x (qw(prefs prefs_file prefs_file_doc)) {
6854                 $self->{$x} = $prefs->{$x};
6855             }
6856             my $bs = sprintf(
6857                              "%s[%s]",
6858                              File::Basename::basename($self->{prefs_file}),
6859                              $self->{prefs_file_doc},
6860                             );
6861             my $filler1 = "_" x 22;
6862             my $filler2 = int(66 - length($bs))/2;
6863             $filler2 = 0 if $filler2 < 0;
6864             $filler2 = " " x $filler2;
6865             $CPAN::Frontend->myprint("
6866 $filler1 D i s t r o P r e f s $filler1
6867 $filler2 $bs $filler2
6868 ");
6869             $CPAN::Frontend->mysleep(1);
6870             return $self->{prefs};
6871         }
6872     }
6873     return +{};
6874 }
6875
6876 # CPAN::Distribution::make_x_arg
6877 sub make_x_arg {
6878     my($self, $whixh) = @_;
6879     my $make_x_arg;
6880     my $prefs = $self->prefs;
6881     if (
6882         $prefs
6883         && exists $prefs->{$whixh}
6884         && exists $prefs->{$whixh}{args}
6885         && $prefs->{$whixh}{args}
6886        ) {
6887         $make_x_arg = join(" ",
6888                            map {CPAN::HandleConfig
6889                                  ->safe_quote($_)} @{$prefs->{$whixh}{args}},
6890                           );
6891     }
6892     my $what = sprintf "make%s_arg", $whixh eq "make" ? "" : $whixh;
6893     $make_x_arg ||= $CPAN::Config->{$what};
6894     return $make_x_arg;
6895 }
6896
6897 # CPAN::Distribution::_make_command
6898 sub _make_command {
6899     my ($self) = @_;
6900     if ($self) {
6901         return
6902             CPAN::HandleConfig
6903                 ->safe_quote(
6904                              CPAN::HandleConfig->prefs_lookup($self,
6905                                                               q{make})
6906                              || $Config::Config{make}
6907                              || 'make'
6908                             );
6909     } else {
6910         # Old style call, without object. Deprecated
6911         Carp::confess("CPAN::_make_command() used as function. Don't Do That.");
6912         return
6913           safe_quote(undef,
6914                      CPAN::HandleConfig->prefs_lookup($self,q{make})
6915                      || $CPAN::Config->{make}
6916                      || $Config::Config{make}
6917                      || 'make');
6918     }
6919 }
6920
6921 #-> sub CPAN::Distribution::follow_prereqs ;
6922 sub follow_prereqs {
6923     my($self) = shift;
6924     my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
6925     return unless @prereq_tuples;
6926     my @prereq = map { $_->[0] } @prereq_tuples;
6927     my $pretty_id = $self->pretty_id;
6928     my %map = (
6929                b => "build_requires",
6930                r => "requires",
6931                c => "commandline",
6932               );
6933     my($filler1,$filler2,$filler3,$filler4);
6934     my $unsat = "Unsatisfied dependencies detected during";
6935     my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id);
6936     {
6937         my $r = int(($w - length($unsat))/2);
6938         my $l = $w - length($unsat) - $r;
6939         $filler1 = "-"x4 . " "x$l;
6940         $filler2 = " "x$r . "-"x4 . "\n";
6941     }
6942     {
6943         my $r = int(($w - length($pretty_id))/2);
6944         my $l = $w - length($pretty_id) - $r;
6945         $filler3 = "-"x4 . " "x$l;
6946         $filler4 = " "x$r . "-"x4 . "\n";
6947     }
6948     $CPAN::Frontend->
6949         myprint("$filler1 $unsat $filler2".
6950                 "$filler3 $pretty_id $filler4".
6951                 join("", map {"    $_->[0] \[$map{$_->[1]}]\n"} @prereq_tuples),
6952                );
6953     my $follow = 0;
6954     if ($CPAN::Config->{prerequisites_policy} eq "follow") {
6955         $follow = 1;
6956     } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
6957         my $answer = CPAN::Shell::colorable_makemaker_prompt(
6958 "Shall I follow them and prepend them to the queue
6959 of modules we are processing right now?", "yes");
6960         $follow = $answer =~ /^\s*y/i;
6961     } else {
6962         local($") = ", ";
6963         $CPAN::Frontend->
6964             myprint("  Ignoring dependencies on modules @prereq\n");
6965     }
6966     if ($follow) {
6967         my $id = $self->id;
6968         # color them as dirty
6969         for my $p (@prereq) {
6970             # warn "calling color_cmd_tmps(0,1)";
6971             CPAN::Shell->expandany($p)->color_cmd_tmps(0,1);
6972         }
6973         # queue them and re-queue yourself
6974         CPAN::Queue->jumpqueue([$id,$self->{reqtype}],
6975                                reverse @prereq_tuples);
6976         $self->{later} = "Delayed until after prerequisites";
6977         return 1; # signal success to the queuerunner
6978     }
6979 }
6980
6981 #-> sub CPAN::Distribution::unsat_prereq ;
6982 # return ([Foo=>1],[Bar=>1.2]) for normal modules
6983 # return ([perl=>5.008]) if we need a newer perl than we are running under
6984 sub unsat_prereq {
6985     my($self) = @_;
6986     my $prereq_pm = $self->prereq_pm or return;
6987     my(@need);
6988     my %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}});
6989   NEED: while (my($need_module, $need_version) = each %merged) {
6990         my($have_version,$inst_file);
6991         if ($need_module eq "perl") {
6992             $have_version = $];
6993             $inst_file = $^X;
6994         } else {
6995             my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
6996             next if $nmo->uptodate;
6997             $inst_file = $nmo->inst_file;
6998
6999             # if they have not specified a version, we accept any installed one
7000             if (not defined $need_version or
7001                 $need_version eq "0" or
7002                 $need_version eq "undef") {
7003                 next if defined $inst_file;
7004             }
7005
7006             $have_version = $nmo->inst_version;
7007         }
7008
7009         # We only want to install prereqs if either they're not installed
7010         # or if the installed version is too old. We cannot omit this
7011         # check, because if 'force' is in effect, nobody else will check.
7012         if (defined $inst_file) {
7013             my(@all_requirements) = split /\s*,\s*/, $need_version;
7014             local($^W) = 0;
7015             my $ok = 0;
7016           RQ: for my $rq (@all_requirements) {
7017                 if ($rq =~ s|>=\s*||) {
7018                 } elsif ($rq =~ s|>\s*||) {
7019                     # 2005-12: one user
7020                     if (CPAN::Version->vgt($have_version,$rq)){
7021                         $ok++;
7022                     }
7023                     next RQ;
7024                 } elsif ($rq =~ s|!=\s*||) {
7025                     # 2005-12: no user
7026                     if (CPAN::Version->vcmp($have_version,$rq)){
7027                         $ok++;
7028                         next RQ;
7029                     } else {
7030                         last RQ;
7031                     }
7032                 } elsif ($rq =~ m|<=?\s*|) {
7033                     # 2005-12: no user
7034                     $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])");
7035                     $ok++;
7036                     next RQ;
7037                 }
7038                 if (! CPAN::Version->vgt($rq, $have_version)){
7039                     $ok++;
7040                 }
7041                 CPAN->debug(sprintf("need_module[%s]inst_file[%s]".
7042                                     "inst_version[%s]rq[%s]ok[%d]",
7043                                     $need_module,
7044                                     $inst_file,
7045                                     $have_version,
7046                                     CPAN::Version->readable($rq),
7047                                     $ok,
7048                                    )) if $CPAN::DEBUG;
7049             }
7050             next NEED if $ok == @all_requirements;
7051         }
7052
7053         if ($need_module eq "perl") {
7054             return ["perl", $need_version];
7055         }
7056         if ($self->{sponsored_mods}{$need_module}++){
7057             # We have already sponsored it and for some reason it's still
7058             # not available. So we do nothing. Or what should we do?
7059             # if we push it again, we have a potential infinite loop
7060             next;
7061         }
7062         my $needed_as = exists $prereq_pm->{requires}{$need_module} ? "r" : "b";
7063         push @need, [$need_module,$needed_as];
7064     }
7065     @need;
7066 }
7067
7068 #-> sub CPAN::Distribution::read_yaml ;
7069 sub read_yaml {
7070     my($self) = @_;
7071     return $self->{yaml_content} if exists $self->{yaml_content};
7072     my $build_dir = $self->{build_dir};
7073     my $yaml = File::Spec->catfile($build_dir,"META.yml");
7074     $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
7075     return unless -f $yaml;
7076     eval { $self->{yaml_content} = CPAN->_yaml_loadfile($yaml)->[0]; };
7077     if ($@) {
7078         $CPAN::Frontend->mywarn("Warning (probably harmless): Could not read ".
7079                                 "'$yaml'. Falling back to other ".
7080                                 "methods to determine prerequisites\n");
7081         return; # if we die, then we cannot read YAML's own META.yml
7082     }
7083     if (not exists $self->{yaml_content}{dynamic_config}
7084         or $self->{yaml_content}{dynamic_config}
7085        ) {
7086         $self->{yaml_content} = undef;
7087     }
7088     $self->debug(sprintf "yaml_content[%s]", $self->{yaml_content} || "UNDEF")
7089         if $CPAN::DEBUG;
7090     return $self->{yaml_content};
7091 }
7092
7093 #-> sub CPAN::Distribution::prereq_pm ;
7094 sub prereq_pm {
7095     my($self) = @_;
7096     $self->{prereq_pm_detected} ||= 0;
7097     CPAN->debug("prereq_pm_detected[$self->{prereq_pm_detected}]") if $CPAN::DEBUG;
7098     return $self->{prereq_pm} if $self->{prereq_pm_detected};
7099     return unless $self->{writemakefile}  # no need to have succeeded
7100                                           # but we must have run it
7101         || $self->{modulebuild};
7102     CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
7103                 $self->{writemakefile}||"",
7104                 $self->{modulebuild}||"",
7105                ) if $CPAN::DEBUG;
7106     my($req,$breq);
7107     if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
7108         $req =  $yaml->{requires} || {};
7109         $breq =  $yaml->{build_requires} || {};
7110         undef $req unless ref $req eq "HASH" && %$req;
7111         if ($req) {
7112             if ($yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
7113                 my $eummv = do { local $^W = 0; $1+0; };
7114                 if ($eummv < 6.2501) {
7115                     # thanks to Slaven for digging that out: MM before
7116                     # that could be wrong because it could reflect a
7117                     # previous release
7118                     undef $req;
7119                 }
7120             }
7121             my $areq;
7122             my $do_replace;
7123             while (my($k,$v) = each %{$req||{}}) {
7124                 if ($v =~ /\d/) {
7125                     $areq->{$k} = $v;
7126                 } elsif ($k =~ /[A-Za-z]/ &&
7127                          $v =~ /[A-Za-z]/ &&
7128                          $CPAN::META->exists("Module",$v)
7129                         ) {
7130                     $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
7131                                             "requires hash: $k => $v; I'll take both ".
7132                                             "key and value as a module name\n");
7133                     $CPAN::Frontend->mysleep(1);
7134                     $areq->{$k} = 0;
7135                     $areq->{$v} = 0;
7136                     $do_replace++;
7137                 }
7138             }
7139             $req = $areq if $do_replace;
7140         }
7141     }
7142     unless ($req || $breq) {
7143         my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
7144         my $makefile = File::Spec->catfile($build_dir,"Makefile");
7145         my $fh;
7146         if (-f $makefile
7147             and
7148             $fh = FileHandle->new("<$makefile\0")) {
7149             CPAN->debug("Getting prereq from Makefile") if $CPAN::DEBUG;
7150             local($/) = "\n";
7151             while (<$fh>) {
7152                 last if /MakeMaker post_initialize section/;
7153                 my($p) = m{^[\#]
7154                            \s+PREREQ_PM\s+=>\s+(.+)
7155                        }x;
7156                 next unless $p;
7157                 # warn "Found prereq expr[$p]";
7158
7159                 #  Regexp modified by A.Speer to remember actual version of file
7160                 #  PREREQ_PM hash key wants, then add to
7161                 while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
7162                     # In case a prereq is mentioned twice, complain.
7163                     if ( defined $req->{$1} ) {
7164                         warn "Warning: PREREQ_PM mentions $1 more than once, ".
7165                             "last mention wins";
7166                     }
7167                     $req->{$1} = $2;
7168                 }
7169                 last;
7170             }
7171         }
7172     }
7173     unless ($req || $breq) {
7174         my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
7175         my $buildfile = File::Spec->catfile($build_dir,"Build");
7176         if (-f $buildfile) {
7177             CPAN->debug("Found '$buildfile'") if $CPAN::DEBUG;
7178             my $build_prereqs = File::Spec->catfile($build_dir,"_build","prereqs");
7179             if (-f $build_prereqs) {
7180                 CPAN->debug("Getting prerequisites from '$build_prereqs'") if $CPAN::DEBUG;
7181                 my $content = do { local *FH;
7182                                    open FH, $build_prereqs
7183                                        or $CPAN::Frontend->mydie("Could not open ".
7184                                                                  "'$build_prereqs': $!");
7185                                    local $/;
7186                                    <FH>;
7187                                };
7188                 my $bphash = eval $content;
7189                 if ($@) {
7190                 } else {
7191                     $req  = $bphash->{requires} || +{};
7192                     $breq = $bphash->{build_requires} || +{};
7193                 }
7194             }
7195         }
7196     }
7197     if (-f "Build.PL"
7198         && ! -f "Makefile.PL"
7199         && ! exists $req->{"Module::Build"}
7200         && ! $CPAN::META->has_inst("Module::Build")) {
7201         $CPAN::Frontend->mywarn("  Warning: CPAN.pm discovered Module::Build as ".
7202                                 "undeclared prerequisite.\n".
7203                                 "  Adding it now as such.\n"
7204                                );
7205         $CPAN::Frontend->mysleep(5);
7206         $req->{"Module::Build"} = 0;
7207         delete $self->{writemakefile};
7208     }
7209     if ($req || $breq) {
7210         $self->{prereq_pm_detected}++;
7211         return $self->{prereq_pm} = { requires => $req, build_requires => $breq };
7212     }
7213 }
7214
7215 #-> sub CPAN::Distribution::test ;
7216 sub test {
7217     my($self) = @_;
7218     if (my $goto = $self->prefs->{goto}) {
7219         return $self->goto($goto);
7220     }
7221     $self->make;
7222     if ($CPAN::Signal){
7223       delete $self->{force_update};
7224       return;
7225     }
7226     # warn "XDEBUG: checking for notest: $self->{notest} $self";
7227     if ($self->{notest}) {
7228         $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
7229         return 1;
7230     }
7231
7232     my $make = $self->{modulebuild} ? "Build" : "make";
7233
7234     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
7235                            ? $ENV{PERL5LIB}
7236                            : ($ENV{PERLLIB} || "");
7237
7238     $CPAN::META->set_perl5lib;
7239     local $ENV{MAKEFLAGS}; # protect us from outer make calls
7240
7241     $CPAN::Frontend->myprint("Running $make test\n");
7242     if (my @prereq = $self->unsat_prereq){
7243         unless ($prereq[0][0] eq "perl") {
7244             return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
7245         }
7246     }
7247   EXCUSE: {
7248         my @e;
7249         unless (exists $self->{make} or exists $self->{later}) {
7250             push @e,
7251                 "Make had some problems, won't test";
7252         }
7253
7254         exists $self->{make} and
7255             (
7256              UNIVERSAL::can($self->{make},"failed") ?
7257              $self->{make}->failed :
7258              $self->{make} =~ /^NO/
7259             ) and push @e, "Can't test without successful make";
7260
7261         $self->{badtestcnt} ||= 0;
7262         $self->{badtestcnt} > 0 and
7263             push @e, "Won't repeat unsuccessful test during this command";
7264
7265         exists $self->{later} and length($self->{later}) and
7266             push @e, $self->{later};
7267
7268         if (exists $self->{build_dir}) {
7269             if ($CPAN::META->{is_tested}{$self->{build_dir}}
7270                 &&
7271                 exists $self->{make_test}
7272                 &&
7273                 !(
7274                   UNIVERSAL::can($self->{make_test},"failed") ?
7275                   $self->{make_test}->failed :
7276                   $self->{make_test} =~ /^NO/
7277                  )
7278                ) {
7279                 push @e, "Already tested successfully";
7280             }
7281         } elsif (!@e) {
7282             push @e, "Has no own directory";
7283         }
7284
7285         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
7286     }
7287     chdir $self->{'build_dir'} or
7288         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
7289     $self->debug("Changed directory to $self->{'build_dir'}")
7290         if $CPAN::DEBUG;
7291
7292     if ($^O eq 'MacOS') {
7293         Mac::BuildTools::make_test($self);
7294         return;
7295     }
7296
7297     if ($self->{modulebuild}) {
7298         my $v = CPAN::Shell->expand("Module","Test::Harness")->inst_version;
7299         if (CPAN::Version->vlt($v,2.62)) {
7300             $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
7301   '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n});
7302             $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old");
7303             return;
7304         }
7305     }
7306
7307     my $system;
7308     if ($self->{modulebuild}) {
7309         $system = sprintf "%s test", $self->_build_command();
7310     } else {
7311         $system = join " ", $self->_make_command(), "test";
7312     }
7313     my($tests_ok);
7314     my %env;
7315     while (my($k,$v) = each %ENV) {
7316         next unless defined $v;
7317         $env{$k} = $v;
7318     }
7319     local %ENV = %env;
7320     if (my $env = $self->prefs->{test}{env}) {
7321         for my $e (keys %$env) {
7322             $ENV{$e} = $env->{$e};
7323         }
7324     }
7325     my $expect_model = $self->_prefs_with_expect("test");
7326     my $want_expect = 0;
7327     if ( $expect_model && @{$expect_model->{talk}} ) {
7328         my $can_expect = $CPAN::META->has_inst("Expect");
7329         if ($can_expect) {
7330             $want_expect = 1;
7331         } else {
7332             $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
7333                                     "testing without\n");
7334         }
7335     }
7336     my $test_report = CPAN::HandleConfig->prefs_lookup($self,
7337                                                        q{test_report});
7338     my $want_report;
7339     if ($test_report) {
7340         my $can_report = $CPAN::META->has_inst("CPAN::Reporter");
7341         if ($can_report) {
7342             $want_report = 1;
7343         } else {
7344             $CPAN::Frontend->mywarn("CPAN::Reporter not installed, falling back to ".
7345                                     "testing without\n");
7346         }
7347     }
7348     my $ready_to_report = $want_report;
7349     if ($ready_to_report
7350         && (
7351             substr($self->id,-1,1) eq "."
7352             ||
7353             $self->author->id eq "LOCAL"
7354            )
7355        ) {
7356         $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
7357                                 "for local directories\n");
7358         $ready_to_report = 0;
7359     }
7360     if ($ready_to_report
7361         &&
7362         $self->prefs->{patches}
7363         &&
7364         @{$self->prefs->{patches}}
7365         &&
7366         $self->{patched}
7367        ) {
7368         $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
7369                                 "when the source has been patched\n");
7370         $ready_to_report = 0;
7371     }
7372     if ($want_expect) {
7373         if ($ready_to_report) {
7374             $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ".
7375                                     "not supported when distroprefs specify ".
7376                                     "an interactive test\n");
7377         }
7378         $tests_ok = $self->_run_via_expect($system,$expect_model) == 0;
7379     } elsif ( $ready_to_report ) {
7380         $tests_ok = CPAN::Reporter::test($self, $system);
7381     } else {
7382         $tests_ok = system($system) == 0;
7383     }
7384     $self->introduce_myself;
7385     if ( $tests_ok ) {
7386         {
7387             my @prereq;
7388             for my $m (keys %{$self->{sponsored_mods}}) {
7389                 my $m_obj = CPAN::Shell->expand("Module",$m);
7390                 my $d_obj = $m_obj->distribution;
7391                 if ($d_obj) {
7392                     if (!$d_obj->{make_test}
7393                         ||
7394                         $d_obj->{make_test}->failed){
7395                         #$m_obj->dump;
7396                         push @prereq, $m;
7397                     }
7398                 }
7399             }
7400             if (@prereq){
7401                 my $cnt = @prereq;
7402                 my $which = join ",", @prereq;
7403                 my $verb = $cnt == 1 ? "one dependency not OK ($which)" :
7404                     "$cnt dependencies missing ($which)";
7405                 $CPAN::Frontend->mywarn("Tests succeeded but $verb\n");
7406                 $self->{make_test} = CPAN::Distrostatus->new("NO $verb");
7407                 $self->store_persistent_state;
7408                 return;
7409             }
7410         }
7411
7412         $CPAN::Frontend->myprint("  $system -- OK\n");
7413         $CPAN::META->is_tested($self->{'build_dir'});
7414         $self->{make_test} = CPAN::Distrostatus->new("YES");
7415     } else {
7416         $self->{make_test} = CPAN::Distrostatus->new("NO");
7417         $self->{badtestcnt}++;
7418         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
7419     }
7420     $self->store_persistent_state;
7421 }
7422
7423 sub _prefs_with_expect {
7424     my($self,$where) = @_;
7425     return unless my $prefs = $self->prefs;
7426     return unless my $where_prefs = $prefs->{$where};
7427     if ($where_prefs->{expect}) {
7428         return {
7429                 mode => "expect",
7430                 talk => $where_prefs->{expect},
7431                };
7432     } elsif ($where_prefs->{"expect-in-any-order"}) {
7433         return {
7434                 mode => "expect-in-any-order",
7435                 talk => $where_prefs->{"expect-in-any-order"},
7436                };
7437     }
7438     return;
7439 }
7440
7441 #-> sub CPAN::Distribution::clean ;
7442 sub clean {
7443     my($self) = @_;
7444     my $make = $self->{modulebuild} ? "Build" : "make";
7445     $CPAN::Frontend->myprint("Running $make clean\n");
7446     unless (exists $self->{archived}) {
7447         $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped".
7448                                 "/untarred, nothing done\n");
7449         return 1;
7450     }
7451     unless (exists $self->{build_dir}) {
7452         $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
7453         return 1;
7454     }
7455   EXCUSE: {
7456         my @e;
7457         exists $self->{make_clean} and $self->{make_clean} eq "YES" and
7458             push @e, "make clean already called once";
7459         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
7460     }
7461     chdir $self->{'build_dir'} or
7462         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
7463     $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
7464
7465     if ($^O eq 'MacOS') {
7466         Mac::BuildTools::make_clean($self);
7467         return;
7468     }
7469
7470     my $system;
7471     if ($self->{modulebuild}) {
7472         unless (-f "Build") {
7473             my $cwd = Cwd::cwd;
7474             $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
7475                                     " in cwd[$cwd]. Danger, Will Robinson!");
7476             $CPAN::Frontend->mysleep(5);
7477         }
7478         $system = sprintf "%s clean", $self->_build_command();
7479     } else {
7480         $system  = join " ", $self->_make_command(), "clean";
7481     }
7482     my $system_ok = system($system) == 0;
7483     $self->introduce_myself;
7484     if ( $system_ok ) {
7485       $CPAN::Frontend->myprint("  $system -- OK\n");
7486
7487       # $self->force;
7488
7489       # Jost Krieger pointed out that this "force" was wrong because
7490       # it has the effect that the next "install" on this distribution
7491       # will untar everything again. Instead we should bring the
7492       # object's state back to where it is after untarring.
7493
7494       for my $k (qw(
7495                     force_update
7496                     install
7497                     writemakefile
7498                     make
7499                     make_test
7500                    )) {
7501           delete $self->{$k};
7502       }
7503       $self->{make_clean} = CPAN::Distrostatus->new("YES");
7504
7505     } else {
7506       # Hmmm, what to do if make clean failed?
7507
7508       $self->{make_clean} = CPAN::Distrostatus->new("NO");
7509       $CPAN::Frontend->mywarn(qq{  $system -- NOT OK\n});
7510
7511       # 2006-02-27: seems silly to me to force a make now
7512       # $self->force("make"); # so that this directory won't be used again
7513
7514     }
7515     $self->store_persistent_state;
7516 }
7517
7518 #-> sub CPAN::Distribution::install ;
7519 sub goto {
7520     my($self,$goto) = @_;
7521     my($method) = (caller(1))[3];
7522     CPAN->instance("CPAN::Distribution",$goto)->$method;
7523 }
7524
7525 #-> sub CPAN::Distribution::install ;
7526 sub install {
7527     my($self) = @_;
7528     if (my $goto = $self->prefs->{goto}) {
7529         return $self->goto($goto);
7530     }
7531     $self->test;
7532     if ($CPAN::Signal){
7533       delete $self->{force_update};
7534       return;
7535     }
7536     my $make = $self->{modulebuild} ? "Build" : "make";
7537     $CPAN::Frontend->myprint("Running $make install\n");
7538   EXCUSE: {
7539         my @e;
7540         unless (exists $self->{make} or exists $self->{later}) {
7541             push @e,
7542                 "Make had some problems, won't install";
7543         }
7544
7545         exists $self->{make} and
7546             (
7547              UNIVERSAL::can($self->{make},"failed") ?
7548              $self->{make}->failed :
7549              $self->{make} =~ /^NO/
7550             ) and
7551                 push @e, "Make had returned bad status, install seems impossible";
7552
7553         if (exists $self->{build_dir}) {
7554         } elsif (!@e) {
7555             push @e, "Has no own directory";
7556         }
7557
7558         if (exists $self->{make_test} and
7559             (
7560              UNIVERSAL::can($self->{make_test},"failed") ?
7561              $self->{make_test}->failed :
7562              $self->{make_test} =~ /^NO/
7563             )){
7564             if ($self->{force_update}) {
7565                 $self->{make_test}->text("FAILED but failure ignored because ".
7566                                          "'force' in effect");
7567             } else {
7568                 push @e, "make test had returned bad status, ".
7569                     "won't install without force"
7570             }
7571         }
7572         if (exists $self->{install}) {
7573             if (UNIVERSAL::can($self->{install},"text") ?
7574                 $self->{install}->text eq "YES" :
7575                 $self->{install} =~ /^YES/
7576                ) {
7577                 push @e, "Already done";
7578             } else {
7579                 # comment in Todo on 2006-02-11; maybe retry?
7580                 push @e, "Already tried without success";
7581             }
7582         }
7583
7584         exists $self->{later} and length($self->{later}) and
7585             push @e, $self->{later};
7586
7587         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
7588     }
7589     chdir $self->{'build_dir'} or
7590         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
7591     $self->debug("Changed directory to $self->{'build_dir'}")
7592         if $CPAN::DEBUG;
7593
7594     if ($^O eq 'MacOS') {
7595         Mac::BuildTools::make_install($self);
7596         return;
7597     }
7598
7599     my $system;
7600     if ($self->{modulebuild}) {
7601         my($mbuild_install_build_command) =
7602             exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
7603                 $CPAN::Config->{mbuild_install_build_command} ?
7604                     $CPAN::Config->{mbuild_install_build_command} :
7605                         $self->_build_command();
7606         $system = sprintf("%s install %s",
7607                           $mbuild_install_build_command,
7608                           $CPAN::Config->{mbuild_install_arg},
7609                          );
7610     } else {
7611         my($make_install_make_command) =
7612             CPAN::HandleConfig->prefs_lookup($self,
7613                                              q{make_install_make_command})
7614                   || $self->_make_command();
7615         $system = sprintf("%s install %s",
7616                           $make_install_make_command,
7617                           $CPAN::Config->{make_install_arg},
7618                          );
7619     }
7620
7621     my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 ";
7622     my $brip = CPAN::HandleConfig->prefs_lookup($self,
7623                                                 q{build_requires_install_policy});
7624     $brip ||="ask/yes";
7625     my $id = $self->id;
7626     my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command
7627     my $want_install = "yes";
7628     if ($reqtype eq "b") {
7629         if ($brip eq "no") {
7630             $want_install = "no";
7631         } elsif ($brip =~ m|^ask/(.+)|) {
7632             my $default = $1;
7633             $default = "yes" unless $default =~ /^(y|n)/i;
7634             $want_install =
7635                 CPAN::Shell::colorable_makemaker_prompt
7636                       ("$id is just needed temporarily during building or testing. ".
7637                        "Do you want to install it permanently? (Y/n)",
7638                        $default);
7639         }
7640     }
7641     unless ($want_install =~ /^y/i) {
7642         my $is_only = "is only 'build_requires'";
7643         $CPAN::Frontend->mywarn("Not installing because $is_only\n");
7644         $self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
7645         delete $self->{force_update};
7646         return;
7647     }
7648     my($pipe) = FileHandle->new("$system $stderr |");
7649     my($makeout) = "";
7650     while (<$pipe>){
7651         print $_; # intentionally NOT use Frontend->myprint because it
7652                   # looks irritating when we markup in color what we
7653                   # just pass through from an external program
7654         $makeout .= $_;
7655     }
7656     $pipe->close;
7657     my $close_ok = $? == 0;
7658     $self->introduce_myself;
7659     if ( $close_ok ) {
7660         $CPAN::Frontend->myprint("  $system -- OK\n");
7661         $CPAN::META->is_installed($self->{build_dir});
7662         return $self->{install} = CPAN::Distrostatus->new("YES");
7663     } else {
7664         $self->{install} = CPAN::Distrostatus->new("NO");
7665         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
7666         my $mimc =
7667             CPAN::HandleConfig->prefs_lookup($self,
7668                                              q{make_install_make_command});
7669         if (
7670             $makeout =~ /permission/s
7671             && $> > 0
7672             && (
7673                 ! $mimc
7674                 || $mimc eq (CPAN::HandleConfig->prefs_lookup($self,
7675                                                               q{make}))
7676                )
7677            ) {
7678             $CPAN::Frontend->myprint(
7679                                      qq{----\n}.
7680                                      qq{  You may have to su }.
7681                                      qq{to root to install the package\n}.
7682                                      qq{  (Or you may want to run something like\n}.
7683                                      qq{    o conf make_install_make_command 'sudo make'\n}.
7684                                      qq{  to raise your permissions.}
7685                                     );
7686         }
7687     }
7688     delete $self->{force_update};
7689     $self->store_persistent_state;
7690 }
7691
7692 sub introduce_myself {
7693     my($self) = @_;
7694     $CPAN::Frontend->myprint(sprintf("  %s\n",$self->pretty_id));
7695 }
7696
7697 #-> sub CPAN::Distribution::dir ;
7698 sub dir {
7699     shift->{'build_dir'};
7700 }
7701
7702 #-> sub CPAN::Distribution::perldoc ;
7703 sub perldoc {
7704     my($self) = @_;
7705
7706     my($dist) = $self->id;
7707     my $package = $self->called_for;
7708
7709     $self->_display_url( $CPAN::Defaultdocs . $package );
7710 }
7711
7712 #-> sub CPAN::Distribution::_check_binary ;
7713 sub _check_binary {
7714     my ($dist,$shell,$binary) = @_;
7715     my ($pid,$out);
7716
7717     $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
7718       if $CPAN::DEBUG;
7719
7720     if ($CPAN::META->has_inst("File::Which")) {
7721         return File::Which::which($binary);
7722     } else {
7723         local *README;
7724         $pid = open README, "which $binary|"
7725             or $CPAN::Frontend->mywarn(qq{Could not fork 'which $binary': $!\n});
7726         return unless $pid;
7727         while (<README>) {
7728             $out .= $_;
7729         }
7730         close README
7731             or $CPAN::Frontend->mywarn("Could not run 'which $binary': $!\n")
7732                 and return;
7733     }
7734
7735     $CPAN::Frontend->myprint(qq{   + $out \n})
7736       if $CPAN::DEBUG && $out;
7737
7738     return $out;
7739 }
7740
7741 #-> sub CPAN::Distribution::_display_url ;
7742 sub _display_url {
7743     my($self,$url) = @_;
7744     my($res,$saved_file,$pid,$out);
7745
7746     $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
7747       if $CPAN::DEBUG;
7748
7749     # should we define it in the config instead?
7750     my $html_converter = "html2text";
7751
7752     my $web_browser = $CPAN::Config->{'lynx'} || undef;
7753     my $web_browser_out = $web_browser
7754       ? CPAN::Distribution->_check_binary($self,$web_browser)
7755         : undef;
7756
7757     if ($web_browser_out) {
7758         # web browser found, run the action
7759         my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
7760         $CPAN::Frontend->myprint(qq{system[$browser $url]})
7761           if $CPAN::DEBUG;
7762         $CPAN::Frontend->myprint(qq{
7763 Displaying URL
7764   $url
7765 with browser $browser
7766 });
7767         $CPAN::Frontend->mysleep(1);
7768         system("$browser $url");
7769         if ($saved_file) { 1 while unlink($saved_file) }
7770     } else {
7771         # web browser not found, let's try text only
7772         my $html_converter_out =
7773           CPAN::Distribution->_check_binary($self,$html_converter);
7774         $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out);
7775
7776         if ($html_converter_out ) {
7777             # html2text found, run it
7778             $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
7779             $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n})
7780                 unless defined($saved_file);
7781
7782             local *README;
7783             $pid = open README, "$html_converter $saved_file |"
7784               or $CPAN::Frontend->mydie(qq{
7785 Could not fork '$html_converter $saved_file': $!});
7786             my($fh,$filename);
7787             if ($CPAN::META->has_inst("File::Temp")) {
7788                 $fh = File::Temp->new(
7789                                       template => 'cpan_htmlconvert_XXXX',
7790                                       suffix => '.txt',
7791                                       unlink => 0,
7792                                      );
7793                 $filename = $fh->filename;
7794             } else {
7795                 $filename = "cpan_htmlconvert_$$.txt";
7796                 $fh = FileHandle->new();
7797                 open $fh, ">$filename" or die;
7798             }
7799             while (<README>) {
7800                 $fh->print($_);
7801             }
7802             close README or
7803                 $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
7804             my $tmpin = $fh->filename;
7805             $CPAN::Frontend->myprint(sprintf(qq{
7806 Run '%s %s' and
7807 saved output to %s\n},
7808                                              $html_converter,
7809                                              $saved_file,
7810                                              $tmpin,
7811                                             )) if $CPAN::DEBUG;
7812             close $fh;
7813             local *FH;
7814             open FH, $tmpin
7815                 or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
7816             my $fh_pager = FileHandle->new;
7817             local($SIG{PIPE}) = "IGNORE";
7818             my $pager = $CPAN::Config->{'pager'} || "cat";
7819             $fh_pager->open("|$pager")
7820                 or $CPAN::Frontend->mydie(qq{
7821 Could not open pager '$pager': $!});
7822             $CPAN::Frontend->myprint(qq{
7823 Displaying URL
7824   $url
7825 with pager "$pager"
7826 });
7827             $CPAN::Frontend->mysleep(1);
7828             $fh_pager->print(<FH>);
7829             $fh_pager->close;
7830         } else {
7831             # coldn't find the web browser or html converter
7832             $CPAN::Frontend->myprint(qq{
7833 You need to install lynx or $html_converter to use this feature.});
7834         }
7835     }
7836 }
7837
7838 #-> sub CPAN::Distribution::_getsave_url ;
7839 sub _getsave_url {
7840     my($dist, $shell, $url) = @_;
7841
7842     $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
7843       if $CPAN::DEBUG;
7844
7845     my($fh,$filename);
7846     if ($CPAN::META->has_inst("File::Temp")) {
7847         $fh = File::Temp->new(
7848                               template => "cpan_getsave_url_XXXX",
7849                               suffix => ".html",
7850                               unlink => 0,
7851                              );
7852         $filename = $fh->filename;
7853     } else {
7854         $fh = FileHandle->new;
7855         $filename = "cpan_getsave_url_$$.html";
7856     }
7857     my $tmpin = $filename;
7858     if ($CPAN::META->has_usable('LWP')) {
7859         $CPAN::Frontend->myprint("Fetching with LWP:
7860   $url
7861 ");
7862         my $Ua;
7863         CPAN::LWP::UserAgent->config;
7864         eval { $Ua = CPAN::LWP::UserAgent->new; };
7865         if ($@) {
7866             $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
7867             return;
7868         } else {
7869             my($var);
7870             $Ua->proxy('http', $var)
7871                 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
7872             $Ua->no_proxy($var)
7873                 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
7874         }
7875
7876         my $req = HTTP::Request->new(GET => $url);
7877         $req->header('Accept' => 'text/html');
7878         my $res = $Ua->request($req);
7879         if ($res->is_success) {
7880             $CPAN::Frontend->myprint(" + request successful.\n")
7881                 if $CPAN::DEBUG;
7882             print $fh $res->content;
7883             close $fh;
7884             $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
7885                 if $CPAN::DEBUG;
7886             return $tmpin;
7887         } else {
7888             $CPAN::Frontend->myprint(sprintf(
7889                                              "LWP failed with code[%s], message[%s]\n",
7890                                              $res->code,
7891                                              $res->message,
7892                                             ));
7893             return;
7894         }
7895     } else {
7896         $CPAN::Frontend->mywarn("  LWP not available\n");
7897         return;
7898     }
7899 }
7900
7901 # sub CPAN::Distribution::_build_command
7902 sub _build_command {
7903     my($self) = @_;
7904     if ($^O eq "MSWin32") { # special code needed at least up to
7905                             # Module::Build 0.2611 and 0.2706; a fix
7906                             # in M:B has been promised 2006-01-30
7907         my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
7908         return "$perl ./Build";
7909     }
7910     return "./Build";
7911 }
7912
7913 package CPAN::Bundle;
7914 use strict;
7915
7916 sub look {
7917     my $self = shift;
7918     $CPAN::Frontend->myprint($self->as_string);
7919 }
7920
7921 sub undelay {
7922     my $self = shift;
7923     delete $self->{later};
7924     for my $c ( $self->contains ) {
7925         my $obj = CPAN::Shell->expandany($c) or next;
7926         $obj->undelay;
7927     }
7928 }
7929
7930 # mark as dirty/clean
7931 #-> sub CPAN::Bundle::color_cmd_tmps ;
7932 sub color_cmd_tmps {
7933     my($self) = shift;
7934     my($depth) = shift || 0;
7935     my($color) = shift || 0;
7936     my($ancestors) = shift || [];
7937     # a module needs to recurse to its cpan_file, a distribution needs
7938     # to recurse into its prereq_pms, a bundle needs to recurse into its modules
7939
7940     return if exists $self->{incommandcolor}
7941         && $self->{incommandcolor}==$color;
7942     if ($depth>=100){
7943         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
7944     }
7945     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
7946
7947     for my $c ( $self->contains ) {
7948         my $obj = CPAN::Shell->expandany($c) or next;
7949         CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
7950         $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
7951     }
7952     if ($color==0) {
7953         delete $self->{badtestcnt};
7954     }
7955     $self->{incommandcolor} = $color;
7956 }
7957
7958 #-> sub CPAN::Bundle::as_string ;
7959 sub as_string {
7960     my($self) = @_;
7961     $self->contains;
7962     # following line must be "=", not "||=" because we have a moving target
7963     $self->{INST_VERSION} = $self->inst_version;
7964     return $self->SUPER::as_string;
7965 }
7966
7967 #-> sub CPAN::Bundle::contains ;
7968 sub contains {
7969     my($self) = @_;
7970     my($inst_file) = $self->inst_file || "";
7971     my($id) = $self->id;
7972     $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
7973     if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) {
7974         undef $inst_file;
7975     }
7976     unless ($inst_file) {
7977         # Try to get at it in the cpan directory
7978         $self->debug("no inst_file") if $CPAN::DEBUG;
7979         my $cpan_file;
7980         $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
7981               $cpan_file = $self->cpan_file;
7982         if ($cpan_file eq "N/A") {
7983             $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
7984   Maybe stale symlink? Maybe removed during session? Giving up.\n");
7985         }
7986         my $dist = $CPAN::META->instance('CPAN::Distribution',
7987                                          $self->cpan_file);
7988         $dist->get;
7989         $self->debug("id[$dist->{ID}]") if $CPAN::DEBUG;
7990         my($todir) = $CPAN::Config->{'cpan_home'};
7991         my(@me,$from,$to,$me);
7992         @me = split /::/, $self->id;
7993         $me[-1] .= ".pm";
7994         $me = File::Spec->catfile(@me);
7995         $from = $self->find_bundle_file($dist->{'build_dir'},join('/',@me));
7996         $to = File::Spec->catfile($todir,$me);
7997         File::Path::mkpath(File::Basename::dirname($to));
7998         File::Copy::copy($from, $to)
7999               or Carp::confess("Couldn't copy $from to $to: $!");
8000         $inst_file = $to;
8001     }
8002     my @result;
8003     my $fh = FileHandle->new;
8004     local $/ = "\n";
8005     open($fh,$inst_file) or die "Could not open '$inst_file': $!";
8006     my $in_cont = 0;
8007     $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
8008     while (<$fh>) {
8009         $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
8010             m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
8011         next unless $in_cont;
8012         next if /^=/;
8013         s/\#.*//;
8014         next if /^\s+$/;
8015         chomp;
8016         push @result, (split " ", $_, 2)[0];
8017     }
8018     close $fh;
8019     delete $self->{STATUS};
8020     $self->{CONTAINS} = \@result;
8021     $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
8022     unless (@result) {
8023         $CPAN::Frontend->mywarn(qq{
8024 The bundle file "$inst_file" may be a broken
8025 bundlefile. It seems not to contain any bundle definition.
8026 Please check the file and if it is bogus, please delete it.
8027 Sorry for the inconvenience.
8028 });
8029     }
8030     @result;
8031 }
8032
8033 #-> sub CPAN::Bundle::find_bundle_file
8034 # $where is in local format, $what is in unix format
8035 sub find_bundle_file {
8036     my($self,$where,$what) = @_;
8037     $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
8038 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
8039 ###    my $bu = File::Spec->catfile($where,$what);
8040 ###    return $bu if -f $bu;
8041     my $manifest = File::Spec->catfile($where,"MANIFEST");
8042     unless (-f $manifest) {
8043         require ExtUtils::Manifest;
8044         my $cwd = CPAN::anycwd();
8045         $self->safe_chdir($where);
8046         ExtUtils::Manifest::mkmanifest();
8047         $self->safe_chdir($cwd);
8048     }
8049     my $fh = FileHandle->new($manifest)
8050         or Carp::croak("Couldn't open $manifest: $!");
8051     local($/) = "\n";
8052     my $bundle_filename = $what;
8053     $bundle_filename =~ s|Bundle.*/||;
8054     my $bundle_unixpath;
8055     while (<$fh>) {
8056         next if /^\s*\#/;
8057         my($file) = /(\S+)/;
8058         if ($file =~ m|\Q$what\E$|) {
8059             $bundle_unixpath = $file;
8060             # return File::Spec->catfile($where,$bundle_unixpath); # bad
8061             last;
8062         }
8063         # retry if she managed to have no Bundle directory
8064         $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
8065     }
8066     return File::Spec->catfile($where, split /\//, $bundle_unixpath)
8067         if $bundle_unixpath;
8068     Carp::croak("Couldn't find a Bundle file in $where");
8069 }
8070
8071 # needs to work quite differently from Module::inst_file because of
8072 # cpan_home/Bundle/ directory and the possibility that we have
8073 # shadowing effect. As it makes no sense to take the first in @INC for
8074 # Bundles, we parse them all for $VERSION and take the newest.
8075
8076 #-> sub CPAN::Bundle::inst_file ;
8077 sub inst_file {
8078     my($self) = @_;
8079     my($inst_file);
8080     my(@me);
8081     @me = split /::/, $self->id;
8082     $me[-1] .= ".pm";
8083     my($incdir,$bestv);
8084     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
8085         my $bfile = File::Spec->catfile($incdir, @me);
8086         CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
8087         next unless -f $bfile;
8088         my $foundv = MM->parse_version($bfile);
8089         if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
8090             $self->{INST_FILE} = $bfile;
8091             $self->{INST_VERSION} = $bestv = $foundv;
8092         }
8093     }
8094     $self->{INST_FILE};
8095 }
8096
8097 #-> sub CPAN::Bundle::inst_version ;
8098 sub inst_version {
8099     my($self) = @_;
8100     $self->inst_file; # finds INST_VERSION as side effect
8101     $self->{INST_VERSION};
8102 }
8103
8104 #-> sub CPAN::Bundle::rematein ;
8105 sub rematein {
8106     my($self,$meth) = @_;
8107     $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
8108     my($id) = $self->id;
8109     Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
8110         unless $self->inst_file || $self->cpan_file;
8111     my($s,%fail);
8112     for $s ($self->contains) {
8113         my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
8114             $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
8115         if ($type eq 'CPAN::Distribution') {
8116             $CPAN::Frontend->mywarn(qq{
8117 The Bundle }.$self->id.qq{ contains
8118 explicitly a file '$s'.
8119 Going to $meth that.
8120 });
8121             $CPAN::Frontend->mysleep(5);
8122         }
8123         # possibly noisy action:
8124         $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
8125         my $obj = $CPAN::META->instance($type,$s);
8126         $obj->{reqtype} = $self->{reqtype};
8127         $obj->$meth();
8128         if ($obj->isa('CPAN::Bundle')
8129             &&
8130             exists $obj->{install_failed}
8131             &&
8132             ref($obj->{install_failed}) eq "HASH"
8133            ) {
8134           for (keys %{$obj->{install_failed}}) {
8135             $self->{install_failed}{$_} = undef; # propagate faiure up
8136                                                  # to me in a
8137                                                  # recursive call
8138             $fail{$s} = 1; # the bundle itself may have succeeded but
8139                            # not all children
8140           }
8141         } else {
8142           my $success;
8143           $success = $obj->can("uptodate") ? $obj->uptodate : 0;
8144           $success ||= $obj->{install} && $obj->{install} eq "YES";
8145           if ($success) {
8146             delete $self->{install_failed}{$s};
8147           } else {
8148             $fail{$s} = 1;
8149           }
8150         }
8151     }
8152
8153     # recap with less noise
8154     if ( $meth eq "install" ) {
8155         if (%fail) {
8156             require Text::Wrap;
8157             my $raw = sprintf(qq{Bundle summary:
8158 The following items in bundle %s had installation problems:},
8159                               $self->id
8160                              );
8161             $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
8162             $CPAN::Frontend->myprint("\n");
8163             my $paragraph = "";
8164             my %reported;
8165             for $s ($self->contains) {
8166               if ($fail{$s}){
8167                 $paragraph .= "$s ";
8168                 $self->{install_failed}{$s} = undef;
8169                 $reported{$s} = undef;
8170               }
8171             }
8172             my $report_propagated;
8173             for $s (sort keys %{$self->{install_failed}}) {
8174               next if exists $reported{$s};
8175               $paragraph .= "and the following items had problems
8176 during recursive bundle calls: " unless $report_propagated++;
8177               $paragraph .= "$s ";
8178             }
8179             $CPAN::Frontend->myprint(Text::Wrap::fill("  ","  ",$paragraph));
8180             $CPAN::Frontend->myprint("\n");
8181         } else {
8182             $self->{install} = 'YES';
8183         }
8184     }
8185 }
8186
8187 # If a bundle contains another that contains an xs_file we have here,
8188 # we just don't bother I suppose
8189 #-> sub CPAN::Bundle::xs_file
8190 sub xs_file {
8191     return 0;
8192 }
8193
8194 #-> sub CPAN::Bundle::force ;
8195 sub force   { shift->rematein('force',@_); }
8196 #-> sub CPAN::Bundle::notest ;
8197 sub notest  { shift->rematein('notest',@_); }
8198 #-> sub CPAN::Bundle::get ;
8199 sub get     { shift->rematein('get',@_); }
8200 #-> sub CPAN::Bundle::make ;
8201 sub make    { shift->rematein('make',@_); }
8202 #-> sub CPAN::Bundle::test ;
8203 sub test    {
8204     my $self = shift;
8205     $self->{badtestcnt} ||= 0;
8206     $self->rematein('test',@_);
8207 }
8208 #-> sub CPAN::Bundle::install ;
8209 sub install {
8210   my $self = shift;
8211   $self->rematein('install',@_);
8212 }
8213 #-> sub CPAN::Bundle::clean ;
8214 sub clean   { shift->rematein('clean',@_); }
8215
8216 #-> sub CPAN::Bundle::uptodate ;
8217 sub uptodate {
8218     my($self) = @_;
8219     return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
8220     my $c;
8221     foreach $c ($self->contains) {
8222         my $obj = CPAN::Shell->expandany($c);
8223         return 0 unless $obj->uptodate;
8224     }
8225     return 1;
8226 }
8227
8228 #-> sub CPAN::Bundle::readme ;
8229 sub readme  {
8230     my($self) = @_;
8231     my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
8232 No File found for bundle } . $self->id . qq{\n}), return;
8233     $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
8234     $CPAN::META->instance('CPAN::Distribution',$file)->readme;
8235 }
8236
8237 package CPAN::Module;
8238 use strict;
8239
8240 # Accessors
8241 # sub CPAN::Module::userid
8242 sub userid {
8243     my $self = shift;
8244     my $ro = $self->ro;
8245     return unless $ro;
8246     return $ro->{userid} || $ro->{CPAN_USERID};
8247 }
8248 # sub CPAN::Module::description
8249 sub description {
8250     my $self = shift;
8251     my $ro = $self->ro or return "";
8252     $ro->{description}
8253 }
8254
8255 sub distribution {
8256     my($self) = @_;
8257     CPAN::Shell->expand("Distribution",$self->cpan_file);
8258 }
8259
8260 # sub CPAN::Module::undelay
8261 sub undelay {
8262     my $self = shift;
8263     delete $self->{later};
8264     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
8265         $dist->undelay;
8266     }
8267 }
8268
8269 # mark as dirty/clean
8270 #-> sub CPAN::Module::color_cmd_tmps ;
8271 sub color_cmd_tmps {
8272     my($self) = shift;
8273     my($depth) = shift || 0;
8274     my($color) = shift || 0;
8275     my($ancestors) = shift || [];
8276     # a module needs to recurse to its cpan_file
8277
8278     return if exists $self->{incommandcolor}
8279         && $self->{incommandcolor}==$color;
8280     return if $depth>=1 && $self->uptodate;
8281     if ($depth>=100){
8282         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
8283     }
8284     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
8285
8286     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
8287         $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
8288     }
8289     if ($color==0) {
8290         delete $self->{badtestcnt};
8291     }
8292     $self->{incommandcolor} = $color;
8293 }
8294
8295 #-> sub CPAN::Module::as_glimpse ;
8296 sub as_glimpse {
8297     my($self) = @_;
8298     my(@m);
8299     my $class = ref($self);
8300     $class =~ s/^CPAN:://;
8301     my $color_on = "";
8302     my $color_off = "";
8303     if (
8304         $CPAN::Shell::COLOR_REGISTERED
8305         &&
8306         $CPAN::META->has_inst("Term::ANSIColor")
8307         &&
8308         $self->description
8309        ) {
8310         $color_on = Term::ANSIColor::color("green");
8311         $color_off = Term::ANSIColor::color("reset");
8312     }
8313     my $uptodateness = " ";
8314     if ($class eq "Bundle") {
8315     } elsif ($self->uptodate) {
8316         $uptodateness = "=";
8317     } elsif ($self->inst_version) {
8318         $uptodateness = "<";
8319     }
8320     push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n",
8321                      $class,
8322                      $uptodateness,
8323                      $color_on,
8324                      $self->id,
8325                      $color_off,
8326                      ($self->distribution ?
8327                       $self->distribution->pretty_id :
8328                       $self->cpan_userid
8329                      ),
8330                     );
8331     join "", @m;
8332 }
8333
8334 #-> sub CPAN::Module::dslip_status
8335 sub dslip_status {
8336     my($self) = @_;
8337     my($stat);
8338     @{$stat->{D}}{qw,i c a b R M S,}     = qw,idea
8339                                               pre-alpha alpha beta released
8340                                               mature standard,;
8341     @{$stat->{S}}{qw,m d u n a,}         = qw,mailing-list
8342                                               developer comp.lang.perl.*
8343                                               none abandoned,;
8344     @{$stat->{L}}{qw,p c + o h,}         = qw,perl C C++ other hybrid,;
8345     @{$stat->{I}}{qw,f r O p h n,}       = qw,functions
8346                                               references+ties
8347                                               object-oriented pragma
8348                                               hybrid none,;
8349     @{$stat->{P}}{qw,p g l b a o d r n,} = qw,Standard-Perl
8350                                               GPL LGPL
8351                                               BSD Artistic
8352                                               open-source
8353                                               distribution_allowed
8354                                               restricted_distribution
8355                                               no_licence,;
8356     for my $x (qw(d s l i p)) {
8357         $stat->{$x}{' '} = 'unknown';
8358         $stat->{$x}{'?'} = 'unknown';
8359     }
8360     my $ro = $self->ro;
8361     return +{} unless $ro && $ro->{statd};
8362     return {
8363             D  => $ro->{statd},
8364             S  => $ro->{stats},
8365             L  => $ro->{statl},
8366             I  => $ro->{stati},
8367             P  => $ro->{statp},
8368             DV => $stat->{D}{$ro->{statd}},
8369             SV => $stat->{S}{$ro->{stats}},
8370             LV => $stat->{L}{$ro->{statl}},
8371             IV => $stat->{I}{$ro->{stati}},
8372             PV => $stat->{P}{$ro->{statp}},
8373            };
8374 }
8375
8376 #-> sub CPAN::Module::as_string ;
8377 sub as_string {
8378     my($self) = @_;
8379     my(@m);
8380     CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
8381     my $class = ref($self);
8382     $class =~ s/^CPAN:://;
8383     local($^W) = 0;
8384     push @m, $class, " id = $self->{ID}\n";
8385     my $sprintf = "    %-12s %s\n";
8386     push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
8387         if $self->description;
8388     my $sprintf2 = "    %-12s %s (%s)\n";
8389     my($userid);
8390     $userid = $self->userid;
8391     if ( $userid ){
8392         my $author;
8393         if ($author = CPAN::Shell->expand('Author',$userid)) {
8394           my $email = "";
8395           my $m; # old perls
8396           if ($m = $author->email) {
8397             $email = " <$m>";
8398           }
8399           push @m, sprintf(
8400                            $sprintf2,
8401                            'CPAN_USERID',
8402                            $userid,
8403                            $author->fullname . $email
8404                           );
8405         }
8406     }
8407     push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
8408         if $self->cpan_version;
8409     if (my $cpan_file = $self->cpan_file){
8410         push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
8411         if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
8412             my $upload_date = $dist->upload_date;
8413             if ($upload_date) {
8414                 push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
8415             }
8416         }
8417     }
8418     my $sprintf3 = "    %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n";
8419     my $dslip = $self->dslip_status;
8420     push @m, sprintf(
8421                      $sprintf3,
8422                      'DSLIP_STATUS',
8423                      @{$dslip}{qw(D S L I P DV SV LV IV PV)},
8424                     ) if $dslip->{D};
8425     my $local_file = $self->inst_file;
8426     unless ($self->{MANPAGE}) {
8427         my $manpage;
8428         if ($local_file) {
8429             $manpage = $self->manpage_headline($local_file);
8430         } else {
8431             # If we have already untarred it, we should look there
8432             my $dist = $CPAN::META->instance('CPAN::Distribution',
8433                                              $self->cpan_file);
8434             # warn "dist[$dist]";
8435             # mff=manifest file; mfh=manifest handle
8436             my($mff,$mfh);
8437             if (
8438                 $dist->{build_dir}
8439                 and
8440                 (-f  ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
8441                 and
8442                 $mfh = FileHandle->new($mff)
8443                ) {
8444                 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
8445                 my $lfre = $self->id; # local file RE
8446                 $lfre =~ s/::/./g;
8447                 $lfre .= "\\.pm\$";
8448                 my($lfl); # local file file
8449                 local $/ = "\n";
8450                 my(@mflines) = <$mfh>;
8451                 for (@mflines) {
8452                     s/^\s+//;
8453                     s/\s.*//s;
8454                 }
8455                 while (length($lfre)>5 and !$lfl) {
8456                     ($lfl) = grep /$lfre/, @mflines;
8457                     CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
8458                     $lfre =~ s/.+?\.//;
8459                 }
8460                 $lfl =~ s/\s.*//; # remove comments
8461                 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
8462                 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
8463                 # warn "lfl_abs[$lfl_abs]";
8464                 if (-f $lfl_abs) {
8465                     $manpage = $self->manpage_headline($lfl_abs);
8466                 }
8467             }
8468         }
8469         $self->{MANPAGE} = $manpage if $manpage;
8470     }
8471     my($item);
8472     for $item (qw/MANPAGE/) {
8473         push @m, sprintf($sprintf, $item, $self->{$item})
8474             if exists $self->{$item};
8475     }
8476     for $item (qw/CONTAINS/) {
8477         push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
8478             if exists $self->{$item} && @{$self->{$item}};
8479     }
8480     push @m, sprintf($sprintf, 'INST_FILE',
8481                      $local_file || "(not installed)");
8482     push @m, sprintf($sprintf, 'INST_VERSION',
8483                      $self->inst_version) if $local_file;
8484     join "", @m, "\n";
8485 }
8486
8487 sub manpage_headline {
8488   my($self,$local_file) = @_;
8489   my(@local_file) = $local_file;
8490   $local_file =~ s/\.pm(?!\n)\Z/.pod/;
8491   push @local_file, $local_file;
8492   my(@result,$locf);
8493   for $locf (@local_file) {
8494     next unless -f $locf;
8495     my $fh = FileHandle->new($locf)
8496         or $Carp::Frontend->mydie("Couldn't open $locf: $!");
8497     my $inpod = 0;
8498     local $/ = "\n";
8499     while (<$fh>) {
8500       $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
8501           m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
8502       next unless $inpod;
8503       next if /^=/;
8504       next if /^\s+$/;
8505       chomp;
8506       push @result, $_;
8507     }
8508     close $fh;
8509     last if @result;
8510   }
8511   for (@result) {
8512       s/^\s+//;
8513       s/\s+$//;
8514   }
8515   join " ", @result;
8516 }
8517
8518 #-> sub CPAN::Module::cpan_file ;
8519 # Note: also inherited by CPAN::Bundle
8520 sub cpan_file {
8521     my $self = shift;
8522     # CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
8523     unless ($self->ro) {
8524         CPAN::Index->reload;
8525     }
8526     my $ro = $self->ro;
8527     if ($ro && defined $ro->{CPAN_FILE}){
8528         return $ro->{CPAN_FILE};
8529     } else {
8530         my $userid = $self->userid;
8531         if ( $userid ) {
8532             if ($CPAN::META->exists("CPAN::Author",$userid)) {
8533                 my $author = $CPAN::META->instance("CPAN::Author",
8534                                                    $userid);
8535                 my $fullname = $author->fullname;
8536                 my $email = $author->email;
8537                 unless (defined $fullname && defined $email) {
8538                     return sprintf("Contact Author %s",
8539                                    $userid,
8540                                   );
8541                 }
8542                 return "Contact Author $fullname <$email>";
8543             } else {
8544                 return "Contact Author $userid (Email address not available)";
8545             }
8546         } else {
8547             return "N/A";
8548         }
8549     }
8550 }
8551
8552 #-> sub CPAN::Module::cpan_version ;
8553 sub cpan_version {
8554     my $self = shift;
8555
8556     my $ro = $self->ro;
8557     unless ($ro) {
8558         # Can happen with modules that are not on CPAN
8559         $ro = {};
8560     }
8561     $ro->{CPAN_VERSION} = 'undef'
8562         unless defined $ro->{CPAN_VERSION};
8563     $ro->{CPAN_VERSION};
8564 }
8565
8566 #-> sub CPAN::Module::force ;
8567 sub force {
8568     my($self) = @_;
8569     $self->{'force_update'}++;
8570 }
8571
8572 sub notest {
8573     my($self) = @_;
8574     # warn "XDEBUG: set notest for Module";
8575     $self->{'notest'}++;
8576 }
8577
8578 #-> sub CPAN::Module::rematein ;
8579 sub rematein {
8580     my($self,$meth) = @_;
8581     $CPAN::Frontend->myprint(sprintf("Running %s for module '%s'\n",
8582                                      $meth,
8583                                      $self->id));
8584     my $cpan_file = $self->cpan_file;
8585     if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
8586       $CPAN::Frontend->mywarn(sprintf qq{
8587   The module %s isn\'t available on CPAN.
8588
8589   Either the module has not yet been uploaded to CPAN, or it is
8590   temporary unavailable. Please contact the author to find out
8591   more about the status. Try 'i %s'.
8592 },
8593                               $self->id,
8594                               $self->id,
8595                              );
8596       return;
8597     }
8598     my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
8599     $pack->called_for($self->id);
8600     $pack->force($meth) if exists $self->{'force_update'};
8601     $pack->notest($meth) if exists $self->{'notest'};
8602
8603     $pack->{reqtype} ||= "";
8604     CPAN->debug("dist-reqtype[$pack->{reqtype}]".
8605                 "self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG;
8606         if ($pack->{reqtype}) {
8607             if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) {
8608                 $pack->{reqtype} = $self->{reqtype};
8609                 if (
8610                     exists $pack->{install}
8611                     &&
8612                     (
8613                      UNIVERSAL::can($pack->{install},"failed") ?
8614                      $pack->{install}->failed :
8615                      $pack->{install} =~ /^NO/
8616                     )
8617                    ) {
8618                     delete $pack->{install};
8619                     $CPAN::Frontend->mywarn
8620                         ("Promoting $pack->{ID} from 'build_requires' to 'requires'");
8621                 }
8622             }
8623         } else {
8624             $pack->{reqtype} = $self->{reqtype};
8625         }
8626
8627     eval {
8628         $pack->$meth();
8629     };
8630     my $err = $@;
8631     $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
8632     $pack->unnotest if $pack->can("unnotest") && exists $self->{'notest'};
8633     delete $self->{'force_update'};
8634     delete $self->{'notest'};
8635     if ($err) {
8636         die $err;
8637     }
8638 }
8639
8640 #-> sub CPAN::Module::perldoc ;
8641 sub perldoc { shift->rematein('perldoc') }
8642 #-> sub CPAN::Module::readme ;
8643 sub readme  { shift->rematein('readme') }
8644 #-> sub CPAN::Module::look ;
8645 sub look    { shift->rematein('look') }
8646 #-> sub CPAN::Module::cvs_import ;
8647 sub cvs_import { shift->rematein('cvs_import') }
8648 #-> sub CPAN::Module::get ;
8649 sub get     { shift->rematein('get',@_) }
8650 #-> sub CPAN::Module::make ;
8651 sub make    { shift->rematein('make') }
8652 #-> sub CPAN::Module::test ;
8653 sub test   {
8654     my $self = shift;
8655     $self->{badtestcnt} ||= 0;
8656     $self->rematein('test',@_);
8657 }
8658 #-> sub CPAN::Module::uptodate ;
8659 sub uptodate {
8660     my($self) = @_;
8661     local($_); # protect against a bug in MakeMaker 6.17
8662     my($latest) = $self->cpan_version;
8663     $latest ||= 0;
8664     my($inst_file) = $self->inst_file;
8665     my($have) = 0;
8666     if (defined $inst_file) {
8667         $have = $self->inst_version;
8668     }
8669     local($^W)=0;
8670     if ($inst_file
8671         &&
8672         ! CPAN::Version->vgt($latest, $have)
8673        ) {
8674         CPAN->debug("returning uptodate. inst_file[$inst_file] ".
8675                     "latest[$latest] have[$have]") if $CPAN::DEBUG;
8676         return 1;
8677     }
8678     return;
8679 }
8680 #-> sub CPAN::Module::install ;
8681 sub install {
8682     my($self) = @_;
8683     my($doit) = 0;
8684     if ($self->uptodate
8685         &&
8686         not exists $self->{'force_update'}
8687        ) {
8688         $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
8689                                          $self->id,
8690                                          $self->inst_version,
8691                                         ));
8692     } else {
8693         $doit = 1;
8694     }
8695     my $ro = $self->ro;
8696     if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
8697         $CPAN::Frontend->mywarn(qq{
8698 \n\n\n     ***WARNING***
8699      The module $self->{ID} has no active maintainer.\n\n\n
8700 });
8701         $CPAN::Frontend->mysleep(5);
8702     }
8703     $self->rematein('install') if $doit;
8704 }
8705 #-> sub CPAN::Module::clean ;
8706 sub clean  { shift->rematein('clean') }
8707
8708 #-> sub CPAN::Module::inst_file ;
8709 sub inst_file {
8710     my($self) = @_;
8711     my($dir,@packpath);
8712     @packpath = split /::/, $self->{ID};
8713     $packpath[-1] .= ".pm";
8714     if (@packpath == 1 && $packpath[0] eq "readline.pm") {
8715         unshift @packpath, "Term", "ReadLine"; # historical reasons
8716     }
8717     foreach $dir (@INC) {
8718         my $pmfile = File::Spec->catfile($dir,@packpath);
8719         if (-f $pmfile){
8720             return $pmfile;
8721         }
8722     }
8723     return;
8724 }
8725
8726 #-> sub CPAN::Module::xs_file ;
8727 sub xs_file {
8728     my($self) = @_;
8729     my($dir,@packpath);
8730     @packpath = split /::/, $self->{ID};
8731     push @packpath, $packpath[-1];
8732     $packpath[-1] .= "." . $Config::Config{'dlext'};
8733     foreach $dir (@INC) {
8734         my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
8735         if (-f $xsfile){
8736             return $xsfile;
8737         }
8738     }
8739     return;
8740 }
8741
8742 #-> sub CPAN::Module::inst_version ;
8743 sub inst_version {
8744     my($self) = @_;
8745     my $parsefile = $self->inst_file or return;
8746     local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
8747     my $have;
8748
8749     $have = MM->parse_version($parsefile);
8750     $have = "undef" unless defined $have && length $have;
8751     $have =~ s/^ //; # since the %vd hack these two lines here are needed
8752     $have =~ s/ $//; # trailing whitespace happens all the time
8753
8754     # My thoughts about why %vd processing should happen here
8755
8756     # Alt1 maintain it as string with leading v:
8757     # read index files     do nothing
8758     # compare it           use utility for compare
8759     # print it             do nothing
8760
8761     # Alt2 maintain it as what it is
8762     # read index files     convert
8763     # compare it           use utility because there's still a ">" vs "gt" issue
8764     # print it             use CPAN::Version for print
8765
8766     # Seems cleaner to hold it in memory as a string starting with a "v"
8767
8768     # If the author of this module made a mistake and wrote a quoted
8769     # "v1.13" instead of v1.13, we simply leave it at that with the
8770     # effect that *we* will treat it like a v-tring while the rest of
8771     # perl won't. Seems sensible when we consider that any action we
8772     # could take now would just add complexity.
8773
8774     $have = CPAN::Version->readable($have);
8775
8776     $have =~ s/\s*//g; # stringify to float around floating point issues
8777     $have; # no stringify needed, \s* above matches always
8778 }
8779
8780 package CPAN;
8781 use strict;
8782
8783 1;
8784
8785
8786 __END__
8787
8788 =head1 NAME
8789
8790 CPAN - query, download and build perl modules from CPAN sites
8791
8792 =head1 SYNOPSIS
8793
8794 Interactive mode:
8795
8796   perl -MCPAN -e shell;
8797
8798 Batch mode:
8799
8800   use CPAN;
8801
8802   # Modules:
8803
8804   cpan> install Acme::Meta                       # in the shell
8805
8806   CPAN::Shell->install("Acme::Meta");            # in perl
8807
8808   # Distributions:
8809
8810   cpan> install NWCLARK/Acme-Meta-0.02.tar.gz    # in the shell
8811
8812   CPAN::Shell->
8813     install("NWCLARK/Acme-Meta-0.02.tar.gz");    # in perl
8814
8815   # module objects:
8816
8817   $mo = CPAN::Shell->expandany($mod);
8818   $mo = CPAN::Shell->expand("Module",$mod);      # same thing
8819
8820   # distribution objects:
8821
8822   $do = CPAN::Shell->expand("Module",$mod)->distribution;
8823   $do = CPAN::Shell->expandany($distro);         # same thing
8824   $do = CPAN::Shell->expand("Distribution",
8825                             $distro);            # same thing
8826
8827 =head1 STATUS
8828
8829 This module and its competitor, the CPANPLUS module, are both much
8830 cooler than the other.
8831
8832 =head1 COMPATIBILITY
8833
8834 CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted
8835 newer versions. It is getting more and more difficult to get the
8836 minimal prerequisites working on older perls. It is close to
8837 impossible to get the whole Bundle::CPAN working there. If you're in
8838 the position to have only these old versions, be advised that CPAN is
8839 designed to work fine without the Bundle::CPAN installed.
8840
8841 To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is
8842 compatible with ancient perls and that File::Temp is listed as a
8843 prerequisite but CPAN has reasonable workarounds if it is missing.
8844
8845 =head1 DESCRIPTION
8846
8847 The CPAN module is designed to automate the make and install of perl
8848 modules and extensions. It includes some primitive searching
8849 capabilities and knows how to use Net::FTP or LWP (or some external
8850 download clients) to fetch the raw data from the net.
8851
8852 Modules are fetched from one or more of the mirrored CPAN
8853 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
8854 directory.
8855
8856 The CPAN module also supports the concept of named and versioned
8857 I<bundles> of modules. Bundles simplify the handling of sets of
8858 related modules. See Bundles below.
8859
8860 The package contains a session manager and a cache manager. There is
8861 no status retained between sessions. The session manager keeps track
8862 of what has been fetched, built and installed in the current
8863 session. The cache manager keeps track of the disk space occupied by
8864 the make processes and deletes excess space according to a simple FIFO
8865 mechanism.
8866
8867 All methods provided are accessible in a programmer style and in an
8868 interactive shell style.
8869
8870 =head2 CPAN::shell([$prompt, $command]) Starting Interactive Mode
8871
8872 The interactive mode is entered by running
8873
8874     perl -MCPAN -e shell
8875
8876 which puts you into a readline interface. You will have the most fun if
8877 you install Term::ReadKey and Term::ReadLine to enjoy both history and
8878 command completion.
8879
8880 Once you are on the command line, type 'h' and the rest should be
8881 self-explanatory.
8882
8883 The function call C<shell> takes two optional arguments, one is the
8884 prompt, the second is the default initial command line (the latter
8885 only works if a real ReadLine interface module is installed).
8886
8887 The most common uses of the interactive modes are
8888
8889 =over 2
8890
8891 =item Searching for authors, bundles, distribution files and modules
8892
8893 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
8894 for each of the four categories and another, C<i> for any of the
8895 mentioned four. Each of the four entities is implemented as a class
8896 with slightly differing methods for displaying an object.
8897
8898 Arguments you pass to these commands are either strings exactly matching
8899 the identification string of an object or regular expressions that are
8900 then matched case-insensitively against various attributes of the
8901 objects. The parser recognizes a regular expression only if you
8902 enclose it between two slashes.
8903
8904 The principle is that the number of found objects influences how an
8905 item is displayed. If the search finds one item, the result is
8906 displayed with the rather verbose method C<as_string>, but if we find
8907 more than one, we display each object with the terse method
8908 C<as_glimpse>.
8909
8910 =item make, test, install, clean  modules or distributions
8911
8912 These commands take any number of arguments and investigate what is
8913 necessary to perform the action. If the argument is a distribution
8914 file name (recognized by embedded slashes), it is processed. If it is
8915 a module, CPAN determines the distribution file in which this module
8916 is included and processes that, following any dependencies named in
8917 the module's META.yml or Makefile.PL (this behavior is controlled by
8918 the configuration parameter C<prerequisites_policy>.)
8919
8920 Any C<make> or C<test> are run unconditionally. An
8921
8922   install <distribution_file>
8923
8924 also is run unconditionally. But for
8925
8926   install <module>
8927
8928 CPAN checks if an install is actually needed for it and prints
8929 I<module up to date> in the case that the distribution file containing
8930 the module doesn't need to be updated.
8931
8932 CPAN also keeps track of what it has done within the current session
8933 and doesn't try to build a package a second time regardless if it
8934 succeeded or not. The C<force> pragma may precede another command
8935 (currently: C<make>, C<test>, or C<install>) and executes the
8936 command from scratch and tries to continue in case of some errors.
8937
8938 Example:
8939
8940     cpan> install OpenGL
8941     OpenGL is up to date.
8942     cpan> force install OpenGL
8943     Running make
8944     OpenGL-0.4/
8945     OpenGL-0.4/COPYRIGHT
8946     [...]
8947
8948 The C<notest> pragma may be set to skip the test part in the build
8949 process.
8950
8951 Example:
8952
8953     cpan> notest install Tk
8954
8955 A C<clean> command results in a
8956
8957   make clean
8958
8959 being executed within the distribution file's working directory.
8960
8961 =item get, readme, perldoc, look module or distribution
8962
8963 C<get> downloads a distribution file without further action. C<readme>
8964 displays the README file of the associated distribution. C<Look> gets
8965 and untars (if not yet done) the distribution file, changes to the
8966 appropriate directory and opens a subshell process in that directory.
8967 C<perldoc> displays the pod documentation of the module in html or
8968 plain text format.
8969
8970 =item ls author
8971
8972 =item ls globbing_expression
8973
8974 The first form lists all distribution files in and below an author's
8975 CPAN directory as they are stored in the CHECKUMS files distributed on
8976 CPAN. The listing goes recursive into all subdirectories.
8977
8978 The second form allows to limit or expand the output with shell
8979 globbing as in the following examples:
8980
8981           ls JV/make*
8982           ls GSAR/*make*
8983           ls */*make*
8984
8985 The last example is very slow and outputs extra progress indicators
8986 that break the alignment of the result.
8987
8988 Note that globbing only lists directories explicitly asked for, for
8989 example FOO/* will not list FOO/bar/Acme-Sthg-n.nn.tar.gz. This may be
8990 regarded as a bug and may be changed in future versions.
8991
8992 =item failed
8993
8994 The C<failed> command reports all distributions that failed on one of
8995 C<make>, C<test> or C<install> for some reason in the currently
8996 running shell session.
8997
8998 =item Lockfile
8999
9000 Interactive sessions maintain a lockfile, per default C<~/.cpan/.lock>.
9001 Batch jobs can run without a lockfile and do not disturb each other.
9002
9003 The shell offers to run in I<degraded mode> when another process is
9004 holding the lockfile. This is an experimental feature that is not yet
9005 tested very well. This second shell then does not write the history
9006 file, does not use the metadata file and has a different prompt.
9007
9008 =item Signals
9009
9010 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
9011 in the cpan-shell it is intended that you can press C<^C> anytime and
9012 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
9013 to clean up and leave the shell loop. You can emulate the effect of a
9014 SIGTERM by sending two consecutive SIGINTs, which usually means by
9015 pressing C<^C> twice.
9016
9017 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
9018 SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl
9019 Build.PL> subprocess.
9020
9021 =back
9022
9023 =head2 CPAN::Shell
9024
9025 The commands that are available in the shell interface are methods in
9026 the package CPAN::Shell. If you enter the shell command, all your
9027 input is split by the Text::ParseWords::shellwords() routine which
9028 acts like most shells do. The first word is being interpreted as the
9029 method to be called and the rest of the words are treated as arguments
9030 to this method. Continuation lines are supported if a line ends with a
9031 literal backslash.
9032
9033 =head2 autobundle
9034
9035 C<autobundle> writes a bundle file into the
9036 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
9037 a list of all modules that are both available from CPAN and currently
9038 installed within @INC. The name of the bundle file is based on the
9039 current date and a counter.
9040
9041 =head2 hosts
9042
9043 This commands provides a statistical overview over recent download
9044 activities. The data for this is collected in the YAML file
9045 C<FTPstats.yml> in your C<cpan_home> directory. If no YAML module is
9046 configured or YAML not installed, then no stats are provided.
9047
9048 =head2 mkmyconfig
9049
9050 mkmyconfig() writes your own CPAN::MyConfig file into your ~/.cpan/
9051 directory so that you can save your own preferences instead of the
9052 system wide ones.
9053
9054 =head2 recompile
9055
9056 recompile() is a very special command in that it takes no argument and
9057 runs the make/test/install cycle with brute force over all installed
9058 dynamically loadable extensions (aka XS modules) with 'force' in
9059 effect. The primary purpose of this command is to finish a network
9060 installation. Imagine, you have a common source tree for two different
9061 architectures. You decide to do a completely independent fresh
9062 installation. You start on one architecture with the help of a Bundle
9063 file produced earlier. CPAN installs the whole Bundle for you, but
9064 when you try to repeat the job on the second architecture, CPAN
9065 responds with a C<"Foo up to date"> message for all modules. So you
9066 invoke CPAN's recompile on the second architecture and you're done.
9067
9068 Another popular use for C<recompile> is to act as a rescue in case your
9069 perl breaks binary compatibility. If one of the modules that CPAN uses
9070 is in turn depending on binary compatibility (so you cannot run CPAN
9071 commands), then you should try the CPAN::Nox module for recovery.
9072
9073 =head2 report Bundle|Distribution|Module
9074
9075 The C<report> command temporarily turns on the C<test_report> config
9076 variable, then runs the C<force test> command with the given
9077 arguments. The C<force> pragma is used to re-run the tests and repeat
9078 every step that might have failed before.
9079
9080 =head2 upgrade [Module|/Regex/]...
9081
9082 The C<upgrade> command first runs an C<r> command with the given
9083 arguments and then installs the newest versions of all modules that
9084 were listed by that.
9085
9086 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
9087
9088 Although it may be considered internal, the class hierarchy does matter
9089 for both users and programmer. CPAN.pm deals with above mentioned four
9090 classes, and all those classes share a set of methods. A classical
9091 single polymorphism is in effect. A metaclass object registers all
9092 objects of all kinds and indexes them with a string. The strings
9093 referencing objects have a separated namespace (well, not completely
9094 separated):
9095
9096          Namespace                         Class
9097
9098    words containing a "/" (slash)      Distribution
9099     words starting with Bundle::          Bundle
9100           everything else            Module or Author
9101
9102 Modules know their associated Distribution objects. They always refer
9103 to the most recent official release. Developers may mark their releases
9104 as unstable development versions (by inserting an underbar into the
9105 module version number which will also be reflected in the distribution
9106 name when you run 'make dist'), so the really hottest and newest
9107 distribution is not always the default.  If a module Foo circulates
9108 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
9109 way to install version 1.23 by saying
9110
9111     install Foo
9112
9113 This would install the complete distribution file (say
9114 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
9115 like to install version 1.23_90, you need to know where the
9116 distribution file resides on CPAN relative to the authors/id/
9117 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
9118 so you would have to say
9119
9120     install BAR/Foo-1.23_90.tar.gz
9121
9122 The first example will be driven by an object of the class
9123 CPAN::Module, the second by an object of class CPAN::Distribution.
9124
9125 =head2 Integrating local directories
9126
9127 Distribution objects are normally distributions from the CPAN, but
9128 there is a slightly degenerate case for Distribution objects, too,
9129 normally only needed by developers. If a distribution object ends with
9130 a dot or is a dot by itself, then it represents a local directory and
9131 all actions such as C<make>, C<test>, and C<install> are applied
9132 directly to that directory. This gives the command C<cpan .> an
9133 interesting touch: while the normal mantra of installing a CPAN module
9134 without CPAN.pm is one of
9135
9136     perl Makefile.PL                 perl Build.PL
9137            ( go and get prerequisites )
9138     make                             ./Build
9139     make test                        ./Build test
9140     make install                     ./Build install
9141
9142 the command C<cpan .> does all of this at once. It figures out which
9143 of the two mantras is appropriate, fetches and installs all
9144 prerequisites, cares for them recursively and finally finishes the
9145 installation of the module in the current directory, be it a CPAN
9146 module or not.
9147
9148 =head1 PROGRAMMER'S INTERFACE
9149
9150 If you do not enter the shell, the available shell commands are both
9151 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
9152 functions in the calling package (C<install(...)>).  Before calling low-level
9153 commands it makes sense to initialize components of CPAN you need, e.g.:
9154
9155   CPAN::HandleConfig->load;
9156   CPAN::Shell::setup_output;
9157   CPAN::Index->reload;
9158
9159 High-level commands do such initializations automatically.
9160
9161 There's currently only one class that has a stable interface -
9162 CPAN::Shell. All commands that are available in the CPAN shell are
9163 methods of the class CPAN::Shell. Each of the commands that produce
9164 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
9165 the IDs of all modules within the list.
9166
9167 =over 2
9168
9169 =item expand($type,@things)
9170
9171 The IDs of all objects available within a program are strings that can
9172 be expanded to the corresponding real objects with the
9173 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
9174 list of CPAN::Module objects according to the C<@things> arguments
9175 given. In scalar context it only returns the first element of the
9176 list.
9177
9178 =item expandany(@things)
9179
9180 Like expand, but returns objects of the appropriate type, i.e.
9181 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
9182 CPAN::Distribution objects for distributions. Note: it does not expand
9183 to CPAN::Author objects.
9184
9185 =item Programming Examples
9186
9187 This enables the programmer to do operations that combine
9188 functionalities that are available in the shell.
9189
9190     # install everything that is outdated on my disk:
9191     perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
9192
9193     # install my favorite programs if necessary:
9194     for $mod (qw(Net::FTP Digest::SHA Data::Dumper)){
9195         CPAN::Shell->install($mod);
9196     }
9197
9198     # list all modules on my disk that have no VERSION number
9199     for $mod (CPAN::Shell->expand("Module","/./")){
9200         next unless $mod->inst_file;
9201         # MakeMaker convention for undefined $VERSION:
9202         next unless $mod->inst_version eq "undef";
9203         print "No VERSION in ", $mod->id, "\n";
9204     }
9205
9206     # find out which distribution on CPAN contains a module:
9207     print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
9208
9209 Or if you want to write a cronjob to watch The CPAN, you could list
9210 all modules that need updating. First a quick and dirty way:
9211
9212     perl -e 'use CPAN; CPAN::Shell->r;'
9213
9214 If you don't want to get any output in the case that all modules are
9215 up to date, you can parse the output of above command for the regular
9216 expression //modules are up to date// and decide to mail the output
9217 only if it doesn't match. Ick?
9218
9219 If you prefer to do it more in a programmer style in one single
9220 process, maybe something like this suits you better:
9221
9222   # list all modules on my disk that have newer versions on CPAN
9223   for $mod (CPAN::Shell->expand("Module","/./")){
9224     next unless $mod->inst_file;
9225     next if $mod->uptodate;
9226     printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
9227         $mod->id, $mod->inst_version, $mod->cpan_version;
9228   }
9229
9230 If that gives you too much output every day, you maybe only want to
9231 watch for three modules. You can write
9232
9233   for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
9234
9235 as the first line instead. Or you can combine some of the above
9236 tricks:
9237
9238   # watch only for a new mod_perl module
9239   $mod = CPAN::Shell->expand("Module","mod_perl");
9240   exit if $mod->uptodate;
9241   # new mod_perl arrived, let me know all update recommendations
9242   CPAN::Shell->r;
9243
9244 =back
9245
9246 =head2 Methods in the other Classes
9247
9248 The programming interface for the classes CPAN::Module,
9249 CPAN::Distribution, CPAN::Bundle, and CPAN::Author is still considered
9250 beta and partially even alpha. In the following paragraphs only those
9251 methods are documented that have proven useful over a longer time and
9252 thus are unlikely to change.
9253
9254 =over 4
9255
9256 =item CPAN::Author::as_glimpse()
9257
9258 Returns a one-line description of the author
9259
9260 =item CPAN::Author::as_string()
9261
9262 Returns a multi-line description of the author
9263
9264 =item CPAN::Author::email()
9265
9266 Returns the author's email address
9267
9268 =item CPAN::Author::fullname()
9269
9270 Returns the author's name
9271
9272 =item CPAN::Author::name()
9273
9274 An alias for fullname
9275
9276 =item CPAN::Bundle::as_glimpse()
9277
9278 Returns a one-line description of the bundle
9279
9280 =item CPAN::Bundle::as_string()
9281
9282 Returns a multi-line description of the bundle
9283
9284 =item CPAN::Bundle::clean()
9285
9286 Recursively runs the C<clean> method on all items contained in the bundle.
9287
9288 =item CPAN::Bundle::contains()
9289
9290 Returns a list of objects' IDs contained in a bundle. The associated
9291 objects may be bundles, modules or distributions.
9292
9293 =item CPAN::Bundle::force($method,@args)
9294
9295 Forces CPAN to perform a task that normally would have failed. Force
9296 takes as arguments a method name to be called and any number of
9297 additional arguments that should be passed to the called method. The
9298 internals of the object get the needed changes so that CPAN.pm does
9299 not refuse to take the action. The C<force> is passed recursively to
9300 all contained objects.
9301
9302 =item CPAN::Bundle::get()
9303
9304 Recursively runs the C<get> method on all items contained in the bundle
9305
9306 =item CPAN::Bundle::inst_file()
9307
9308 Returns the highest installed version of the bundle in either @INC or
9309 C<$CPAN::Config->{cpan_home}>. Note that this is different from
9310 CPAN::Module::inst_file.
9311
9312 =item CPAN::Bundle::inst_version()
9313
9314 Like CPAN::Bundle::inst_file, but returns the $VERSION
9315
9316 =item CPAN::Bundle::uptodate()
9317
9318 Returns 1 if the bundle itself and all its members are uptodate.
9319
9320 =item CPAN::Bundle::install()
9321
9322 Recursively runs the C<install> method on all items contained in the bundle
9323
9324 =item CPAN::Bundle::make()
9325
9326 Recursively runs the C<make> method on all items contained in the bundle
9327
9328 =item CPAN::Bundle::readme()
9329
9330 Recursively runs the C<readme> method on all items contained in the bundle
9331
9332 =item CPAN::Bundle::test()
9333
9334 Recursively runs the C<test> method on all items contained in the bundle
9335
9336 =item CPAN::Distribution::as_glimpse()
9337
9338 Returns a one-line description of the distribution
9339
9340 =item CPAN::Distribution::as_string()
9341
9342 Returns a multi-line description of the distribution
9343
9344 =item CPAN::Distribution::author
9345
9346 Returns the CPAN::Author object of the maintainer who uploaded this
9347 distribution
9348
9349 =item CPAN::Distribution::clean()
9350
9351 Changes to the directory where the distribution has been unpacked and
9352 runs C<make clean> there.
9353
9354 =item CPAN::Distribution::containsmods()
9355
9356 Returns a list of IDs of modules contained in a distribution file.
9357 Only works for distributions listed in the 02packages.details.txt.gz
9358 file. This typically means that only the most recent version of a
9359 distribution is covered.
9360
9361 =item CPAN::Distribution::cvs_import()
9362
9363 Changes to the directory where the distribution has been unpacked and
9364 runs something like
9365
9366     cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
9367
9368 there.
9369
9370 =item CPAN::Distribution::dir()
9371
9372 Returns the directory into which this distribution has been unpacked.
9373
9374 =item CPAN::Distribution::force($method,@args)
9375
9376 Forces CPAN to perform a task that normally would have failed. Force
9377 takes as arguments a method name to be called and any number of
9378 additional arguments that should be passed to the called method. The
9379 internals of the object get the needed changes so that CPAN.pm does
9380 not refuse to take the action.
9381
9382 =item CPAN::Distribution::get()
9383
9384 Downloads the distribution from CPAN and unpacks it. Does nothing if
9385 the distribution has already been downloaded and unpacked within the
9386 current session.
9387
9388 =item CPAN::Distribution::install()
9389
9390 Changes to the directory where the distribution has been unpacked and
9391 runs the external command C<make install> there. If C<make> has not
9392 yet been run, it will be run first. A C<make test> will be issued in
9393 any case and if this fails, the install will be canceled. The
9394 cancellation can be avoided by letting C<force> run the C<install> for
9395 you.
9396
9397 This install method has only the power to install the distribution if
9398 there are no dependencies in the way. To install an object and all of
9399 its dependencies, use CPAN::Shell->install.
9400
9401 Note that install() gives no meaningful return value. See uptodate().
9402
9403 =item CPAN::Distribution::isa_perl()
9404
9405 Returns 1 if this distribution file seems to be a perl distribution.
9406 Normally this is derived from the file name only, but the index from
9407 CPAN can contain a hint to achieve a return value of true for other
9408 filenames too.
9409
9410 =item CPAN::Distribution::look()
9411
9412 Changes to the directory where the distribution has been unpacked and
9413 opens a subshell there. Exiting the subshell returns.
9414
9415 =item CPAN::Distribution::make()
9416
9417 First runs the C<get> method to make sure the distribution is
9418 downloaded and unpacked. Changes to the directory where the
9419 distribution has been unpacked and runs the external commands C<perl
9420 Makefile.PL> or C<perl Build.PL> and C<make> there.
9421
9422 =item CPAN::Distribution::perldoc()
9423
9424 Downloads the pod documentation of the file associated with a
9425 distribution (in html format) and runs it through the external
9426 command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
9427 isn't available, it converts it to plain text with external
9428 command html2text and runs it through the pager specified
9429 in C<$CPAN::Config->{pager}>
9430
9431 =item CPAN::Distribution::prefs()
9432
9433 Returns the hash reference from the first matching YAML file that the
9434 user has deposited in the C<prefs_dir/> directory. The first
9435 succeeding match wins. The files in the C<prefs_dir/> are processed
9436 alphabetically and the canonical distroname (e.g.
9437 AUTHOR/Foo-Bar-3.14.tar.gz) is matched against the regular expressions
9438 stored in the $root->{match}{distribution} attribute value.
9439 Additionally all module names contained in a distribution are matched
9440 agains the regular expressions in the $root->{match}{module} attribute
9441 value. The two match values are ANDed together. Each of the two
9442 attributes are optional.
9443
9444 =item CPAN::Distribution::prereq_pm()
9445
9446 Returns the hash reference that has been announced by a distribution
9447 as the merge of the C<requires> element and the C<build_requires>
9448 element of the META.yml or the C<PREREQ_PM> hash in the
9449 C<Makefile.PL>. Note: works only after an attempt has been made to
9450 C<make> the distribution. Returns undef otherwise.
9451
9452 =item CPAN::Distribution::readme()
9453
9454 Downloads the README file associated with a distribution and runs it
9455 through the pager specified in C<$CPAN::Config->{pager}>.
9456
9457 =item CPAN::Distribution::read_yaml()
9458
9459 Returns the content of the META.yml of this distro as a hashref. Note:
9460 works only after an attempt has been made to C<make> the distribution.
9461 Returns undef otherwise. Also returns undef if the content of META.yml
9462 is dynamic.
9463
9464 =item CPAN::Distribution::test()
9465
9466 Changes to the directory where the distribution has been unpacked and
9467 runs C<make test> there.
9468
9469 =item CPAN::Distribution::uptodate()
9470
9471 Returns 1 if all the modules contained in the distribution are
9472 uptodate. Relies on containsmods.
9473
9474 =item CPAN::Index::force_reload()
9475
9476 Forces a reload of all indices.
9477
9478 =item CPAN::Index::reload()
9479
9480 Reloads all indices if they have not been read for more than
9481 C<$CPAN::Config->{index_expire}> days.
9482
9483 =item CPAN::InfoObj::dump()
9484
9485 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
9486 inherit this method. It prints the data structure associated with an
9487 object. Useful for debugging. Note: the data structure is considered
9488 internal and thus subject to change without notice.
9489
9490 =item CPAN::Module::as_glimpse()
9491
9492 Returns a one-line description of the module in four columns: The
9493 first column contains the word C<Module>, the second column consists
9494 of one character: an equals sign if this module is already installed
9495 and uptodate, a less-than sign if this module is installed but can be
9496 upgraded, and a space if the module is not installed. The third column
9497 is the name of the module and the fourth column gives maintainer or
9498 distribution information.
9499
9500 =item CPAN::Module::as_string()
9501
9502 Returns a multi-line description of the module
9503
9504 =item CPAN::Module::clean()
9505
9506 Runs a clean on the distribution associated with this module.
9507
9508 =item CPAN::Module::cpan_file()
9509
9510 Returns the filename on CPAN that is associated with the module.
9511
9512 =item CPAN::Module::cpan_version()
9513
9514 Returns the latest version of this module available on CPAN.
9515
9516 =item CPAN::Module::cvs_import()
9517
9518 Runs a cvs_import on the distribution associated with this module.
9519
9520 =item CPAN::Module::description()
9521
9522 Returns a 44 character description of this module. Only available for
9523 modules listed in The Module List (CPAN/modules/00modlist.long.html
9524 or 00modlist.long.txt.gz)
9525
9526 =item CPAN::Module::distribution()
9527
9528 Returns the CPAN::Distribution object that contains the current
9529 version of this module.
9530
9531 =item CPAN::Module::dslip_status()
9532
9533 Returns a hash reference. The keys of the hash are the letters C<D>,
9534 C<S>, C<L>, C<I>, and <P>, for development status, support level,
9535 language, interface and public licence respectively. The data for the
9536 DSLIP status are collected by pause.perl.org when authors register
9537 their namespaces. The values of the 5 hash elements are one-character
9538 words whose meaning is described in the table below. There are also 5
9539 hash elements C<DV>, C<SV>, C<LV>, C<IV>, and <PV> that carry a more
9540 verbose value of the 5 status variables.
9541
9542 Where the 'DSLIP' characters have the following meanings:
9543
9544   D - Development Stage  (Note: *NO IMPLIED TIMESCALES*):
9545     i   - Idea, listed to gain consensus or as a placeholder
9546     c   - under construction but pre-alpha (not yet released)
9547     a/b - Alpha/Beta testing
9548     R   - Released
9549     M   - Mature (no rigorous definition)
9550     S   - Standard, supplied with Perl 5
9551
9552   S - Support Level:
9553     m   - Mailing-list
9554     d   - Developer
9555     u   - Usenet newsgroup comp.lang.perl.modules
9556     n   - None known, try comp.lang.perl.modules
9557     a   - abandoned; volunteers welcome to take over maintainance
9558
9559   L - Language Used:
9560     p   - Perl-only, no compiler needed, should be platform independent
9561     c   - C and perl, a C compiler will be needed
9562     h   - Hybrid, written in perl with optional C code, no compiler needed
9563     +   - C++ and perl, a C++ compiler will be needed
9564     o   - perl and another language other than C or C++
9565
9566   I - Interface Style
9567     f   - plain Functions, no references used
9568     h   - hybrid, object and function interfaces available
9569     n   - no interface at all (huh?)
9570     r   - some use of unblessed References or ties
9571     O   - Object oriented using blessed references and/or inheritance
9572
9573   P - Public License
9574     p   - Standard-Perl: user may choose between GPL and Artistic
9575     g   - GPL: GNU General Public License
9576     l   - LGPL: "GNU Lesser General Public License" (previously known as
9577           "GNU Library General Public License")
9578     b   - BSD: The BSD License
9579     a   - Artistic license alone
9580     o   - open source: appoved by www.opensource.org
9581     d   - allows distribution without restrictions
9582     r   - restricted distribtion
9583     n   - no license at all
9584
9585 =item CPAN::Module::force($method,@args)
9586
9587 Forces CPAN to perform a task that normally would have failed. Force
9588 takes as arguments a method name to be called and any number of
9589 additional arguments that should be passed to the called method. The
9590 internals of the object get the needed changes so that CPAN.pm does
9591 not refuse to take the action.
9592
9593 =item CPAN::Module::get()
9594
9595 Runs a get on the distribution associated with this module.
9596
9597 =item CPAN::Module::inst_file()
9598
9599 Returns the filename of the module found in @INC. The first file found
9600 is reported just like perl itself stops searching @INC when it finds a
9601 module.
9602
9603 =item CPAN::Module::inst_version()
9604
9605 Returns the version number of the module in readable format.
9606
9607 =item CPAN::Module::install()
9608
9609 Runs an C<install> on the distribution associated with this module.
9610
9611 =item CPAN::Module::look()
9612
9613 Changes to the directory where the distribution associated with this
9614 module has been unpacked and opens a subshell there. Exiting the
9615 subshell returns.
9616
9617 =item CPAN::Module::make()
9618
9619 Runs a C<make> on the distribution associated with this module.
9620
9621 =item CPAN::Module::manpage_headline()
9622
9623 If module is installed, peeks into the module's manpage, reads the
9624 headline and returns it. Moreover, if the module has been downloaded
9625 within this session, does the equivalent on the downloaded module even
9626 if it is not installed.
9627
9628 =item CPAN::Module::perldoc()
9629
9630 Runs a C<perldoc> on this module.
9631
9632 =item CPAN::Module::readme()
9633
9634 Runs a C<readme> on the distribution associated with this module.
9635
9636 =item CPAN::Module::test()
9637
9638 Runs a C<test> on the distribution associated with this module.
9639
9640 =item CPAN::Module::uptodate()
9641
9642 Returns 1 if the module is installed and up-to-date.
9643
9644 =item CPAN::Module::userid()
9645
9646 Returns the author's ID of the module.
9647
9648 =back
9649
9650 =head2 Cache Manager
9651
9652 Currently the cache manager only keeps track of the build directory
9653 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
9654 deletes complete directories below C<build_dir> as soon as the size of
9655 all directories there gets bigger than $CPAN::Config->{build_cache}
9656 (in MB). The contents of this cache may be used for later
9657 re-installations that you intend to do manually, but will never be
9658 trusted by CPAN itself. This is due to the fact that the user might
9659 use these directories for building modules on different architectures.
9660
9661 There is another directory ($CPAN::Config->{keep_source_where}) where
9662 the original distribution files are kept. This directory is not
9663 covered by the cache manager and must be controlled by the user. If
9664 you choose to have the same directory as build_dir and as
9665 keep_source_where directory, then your sources will be deleted with
9666 the same fifo mechanism.
9667
9668 =head2 Bundles
9669
9670 A bundle is just a perl module in the namespace Bundle:: that does not
9671 define any functions or methods. It usually only contains documentation.
9672
9673 It starts like a perl module with a package declaration and a $VERSION
9674 variable. After that the pod section looks like any other pod with the
9675 only difference being that I<one special pod section> exists starting with
9676 (verbatim):
9677
9678         =head1 CONTENTS
9679
9680 In this pod section each line obeys the format
9681
9682         Module_Name [Version_String] [- optional text]
9683
9684 The only required part is the first field, the name of a module
9685 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
9686 of the line is optional. The comment part is delimited by a dash just
9687 as in the man page header.
9688
9689 The distribution of a bundle should follow the same convention as
9690 other distributions.
9691
9692 Bundles are treated specially in the CPAN package. If you say 'install
9693 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
9694 the modules in the CONTENTS section of the pod. You can install your
9695 own Bundles locally by placing a conformant Bundle file somewhere into
9696 your @INC path. The autobundle() command which is available in the
9697 shell interface does that for you by including all currently installed
9698 modules in a snapshot bundle file.
9699
9700 =head1 PREREQUISITES
9701
9702 If you have a local mirror of CPAN and can access all files with
9703 "file:" URLs, then you only need a perl better than perl5.003 to run
9704 this module. Otherwise Net::FTP is strongly recommended. LWP may be
9705 required for non-UNIX systems or if your nearest CPAN site is
9706 associated with a URL that is not C<ftp:>.
9707
9708 If you have neither Net::FTP nor LWP, there is a fallback mechanism
9709 implemented for an external ftp command or for an external lynx
9710 command.
9711
9712 =head1 UTILITIES
9713
9714 =head2 Finding packages and VERSION
9715
9716 This module presumes that all packages on CPAN
9717
9718 =over 2
9719
9720 =item *
9721
9722 declare their $VERSION variable in an easy to parse manner. This
9723 prerequisite can hardly be relaxed because it consumes far too much
9724 memory to load all packages into the running program just to determine
9725 the $VERSION variable. Currently all programs that are dealing with
9726 version use something like this
9727
9728     perl -MExtUtils::MakeMaker -le \
9729         'print MM->parse_version(shift)' filename
9730
9731 If you are author of a package and wonder if your $VERSION can be
9732 parsed, please try the above method.
9733
9734 =item *
9735
9736 come as compressed or gzipped tarfiles or as zip files and contain a
9737 C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
9738 without much enthusiasm).
9739
9740 =back
9741
9742 =head2 Debugging
9743
9744 The debugging of this module is a bit complex, because we have
9745 interferences of the software producing the indices on CPAN, of the
9746 mirroring process on CPAN, of packaging, of configuration, of
9747 synchronicity, and of bugs within CPAN.pm.
9748
9749 For debugging the code of CPAN.pm itself in interactive mode some more
9750 or less useful debugging aid can be turned on for most packages within
9751 CPAN.pm with one of
9752
9753 =over 2
9754
9755 =item o debug package...
9756
9757 sets debug mode for packages.
9758
9759 =item o debug -package...
9760
9761 unsets debug mode for packages.
9762
9763 =item o debug all
9764
9765 turns debugging on for all packages.
9766
9767 =item o debug number
9768
9769 =back
9770
9771 which sets the debugging packages directly. Note that C<o debug 0>
9772 turns debugging off.
9773
9774 What seems quite a successful strategy is the combination of C<reload
9775 cpan> and the debugging switches. Add a new debug statement while
9776 running in the shell and then issue a C<reload cpan> and see the new
9777 debugging messages immediately without losing the current context.
9778
9779 C<o debug> without an argument lists the valid package names and the
9780 current set of packages in debugging mode. C<o debug> has built-in
9781 completion support.
9782
9783 For debugging of CPAN data there is the C<dump> command which takes
9784 the same arguments as make/test/install and outputs each object's
9785 Data::Dumper dump. If an argument looks like a perl variable and
9786 contains one of C<$>, C<@> or C<%>, it is eval()ed and fed to
9787 Data::Dumper directly.
9788
9789 =head2 Floppy, Zip, Offline Mode
9790
9791 CPAN.pm works nicely without network too. If you maintain machines
9792 that are not networked at all, you should consider working with file:
9793 URLs. Of course, you have to collect your modules somewhere first. So
9794 you might use CPAN.pm to put together all you need on a networked
9795 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
9796 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
9797 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
9798 with this floppy. See also below the paragraph about CD-ROM support.
9799
9800 =head2 Basic Utilities for Programmers
9801
9802 =over 2
9803
9804 =item has_inst($module)
9805
9806 Returns true if the module is installed. See the source for details.
9807
9808 =item has_usable($module)
9809
9810 Returns true if the module is installed and several and is in a usable
9811 state. Only useful for a handful of modules that are used internally.
9812 See the source for details.
9813
9814 =item instance($module)
9815
9816 The constructor for all the singletons used to represent modules,
9817 distributions, authors and bundles. If the object already exists, this
9818 method returns the object, otherwise it calls the constructor.
9819
9820 =back
9821
9822 =head1 CONFIGURATION
9823
9824 When the CPAN module is used for the first time, a configuration
9825 dialog tries to determine a couple of site specific options. The
9826 result of the dialog is stored in a hash reference C< $CPAN::Config >
9827 in a file CPAN/Config.pm.
9828
9829 The default values defined in the CPAN/Config.pm file can be
9830 overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
9831 best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
9832 added to the search path of the CPAN module before the use() or
9833 require() statements. The mkmyconfig command writes this file for you.
9834
9835 The C<o conf> command has various bells and whistles:
9836
9837 =over
9838
9839 =item completion support
9840
9841 If you have a ReadLine module installed, you can hit TAB at any point
9842 of the commandline and C<o conf> will offer you completion for the
9843 built-in subcommands and/or config variable names.
9844
9845 =item displaying some help: o conf help
9846
9847 Displays a short help
9848
9849 =item displaying current values: o conf [KEY]
9850
9851 Displays the current value(s) for this config variable. Without KEY
9852 displays all subcommands and config variables.
9853
9854 Example:
9855
9856   o conf shell
9857
9858 =item changing of scalar values: o conf KEY VALUE
9859
9860 Sets the config variable KEY to VALUE. The empty string can be
9861 specified as usual in shells, with C<''> or C<"">
9862
9863 Example:
9864
9865   o conf wget /usr/bin/wget
9866
9867 =item changing of list values: o conf KEY SHIFT|UNSHIFT|PUSH|POP|SPLICE|LIST
9868
9869 If a config variable name ends with C<list>, it is a list. C<o conf
9870 KEY shift> removes the first element of the list, C<o conf KEY pop>
9871 removes the last element of the list. C<o conf KEYS unshift LIST>
9872 prepends a list of values to the list, C<o conf KEYS push LIST>
9873 appends a list of valued to the list.
9874
9875 Likewise, C<o conf KEY splice LIST> passes the LIST to the according
9876 splice command.
9877
9878 Finally, any other list of arguments is taken as a new list value for
9879 the KEY variable discarding the previous value.
9880
9881 Examples:
9882
9883   o conf urllist unshift http://cpan.dev.local/CPAN
9884   o conf urllist splice 3 1
9885   o conf urllist http://cpan1.local http://cpan2.local ftp://ftp.perl.org
9886
9887 =item interactive editing: o conf init [MATCH|LIST]
9888
9889 Runs an interactive configuration dialog for matching variables.
9890 Without argument runs the dialog over all supported config variables.
9891 To specify a MATCH the argument must be enclosed by slashes.
9892
9893 Examples:
9894
9895   o conf init ftp_passive ftp_proxy
9896   o conf init /color/
9897
9898 =item reverting to saved: o conf defaults
9899
9900 Reverts all config variables to the state in the saved config file.
9901
9902 =item saving the config: o conf commit
9903
9904 Saves all config variables to the current config file (CPAN/Config.pm
9905 or CPAN/MyConfig.pm that was loaded at start).
9906
9907 =back
9908
9909 The configuration dialog can be started any time later again by
9910 issuing the command C< o conf init > in the CPAN shell. A subset of
9911 the configuration dialog can be run by issuing C<o conf init WORD>
9912 where WORD is any valid config variable or a regular expression.
9913
9914 =head2 Config Variables
9915
9916 Currently the following keys in the hash reference $CPAN::Config are
9917 defined:
9918
9919   build_cache        size of cache for directories to build modules
9920   build_dir          locally accessible directory to build modules
9921   build_dir_reuse    boolean if distros in build_dir are persistent
9922   build_requires_install_policy
9923                      to install or not to install: when a module is
9924                      only needed for building. yes|no|ask/yes|ask/no
9925   bzip2              path to external prg
9926   cache_metadata     use serializer to cache metadata
9927   commands_quote     prefered character to use for quoting external
9928                      commands when running them. Defaults to double
9929                      quote on Windows, single tick everywhere else;
9930                      can be set to space to disable quoting
9931   check_sigs         if signatures should be verified
9932   colorize_output    boolean if Term::ANSIColor should colorize output
9933   colorize_print     Term::ANSIColor attributes for normal output
9934   colorize_warn      Term::ANSIColor attributes for warnings
9935   commandnumber_in_prompt
9936                      boolean if you want to see current command number
9937   cpan_home          local directory reserved for this package
9938   curl               path to external prg
9939   dontload_hash      DEPRECATED
9940   dontload_list      arrayref: modules in the list will not be
9941                      loaded by the CPAN::has_inst() routine
9942   ftp                path to external prg
9943   ftp_passive        if set, the envariable FTP_PASSIVE is set for downloads
9944   ftp_proxy          proxy host for ftp requests
9945   getcwd             see below
9946   gpg                path to external prg
9947   gzip               location of external program gzip
9948   histfile           file to maintain history between sessions
9949   histsize           maximum number of lines to keep in histfile
9950   http_proxy         proxy host for http requests
9951   inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
9952                      after this many seconds inactivity. Set to 0 to
9953                      never break.
9954   index_expire       after this many days refetch index files
9955   inhibit_startup_message
9956                      if true, does not print the startup message
9957   keep_source_where  directory in which to keep the source (if we do)
9958   lynx               path to external prg
9959   make               location of external make program
9960   make_arg           arguments that should always be passed to 'make'
9961   make_install_make_command
9962                      the make command for running 'make install', for
9963                      example 'sudo make'
9964   make_install_arg   same as make_arg for 'make install'
9965   makepl_arg         arguments passed to 'perl Makefile.PL'
9966   mbuild_arg         arguments passed to './Build'
9967   mbuild_install_arg arguments passed to './Build install'
9968   mbuild_install_build_command
9969                      command to use instead of './Build' when we are
9970                      in the install stage, for example 'sudo ./Build'
9971   mbuildpl_arg       arguments passed to 'perl Build.PL'
9972   ncftp              path to external prg
9973   ncftpget           path to external prg
9974   no_proxy           don't proxy to these hosts/domains (comma separated list)
9975   pager              location of external program more (or any pager)
9976   password           your password if you CPAN server wants one
9977   patch              path to external prg
9978   prefer_installer   legal values are MB and EUMM: if a module comes
9979                      with both a Makefile.PL and a Build.PL, use the
9980                      former (EUMM) or the latter (MB); if the module
9981                      comes with only one of the two, that one will be
9982                      used in any case
9983   prerequisites_policy
9984                      what to do if you are missing module prerequisites
9985                      ('follow' automatically, 'ask' me, or 'ignore')
9986   prefs_dir          local directory to store per-distro build options
9987   proxy_user         username for accessing an authenticating proxy
9988   proxy_pass         password for accessing an authenticating proxy
9989   randomize_urllist  add some randomness to the sequence of the urllist
9990   scan_cache         controls scanning of cache ('atstart' or 'never')
9991   shell              your favorite shell
9992   show_upload_date   boolean if commands should try to determine upload date
9993   tar                location of external program tar
9994   term_is_latin      if true internal UTF-8 is translated to ISO-8859-1
9995                      (and nonsense for characters outside latin range)
9996   term_ornaments     boolean to turn ReadLine ornamenting on/off
9997   test_report        email test reports (if CPAN::Reporter is installed)
9998   unzip              location of external program unzip
9999   urllist            arrayref to nearby CPAN sites (or equivalent locations)
10000   username           your username if you CPAN server wants one
10001   wait_list          arrayref to a wait server to try (See CPAN::WAIT)
10002   wget               path to external prg
10003   yaml_module        which module to use to read/write YAML files
10004
10005 You can set and query each of these options interactively in the cpan
10006 shell with the command set defined within the C<o conf> command:
10007
10008 =over 2
10009
10010 =item C<o conf E<lt>scalar optionE<gt>>
10011
10012 prints the current value of the I<scalar option>
10013
10014 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
10015
10016 Sets the value of the I<scalar option> to I<value>
10017
10018 =item C<o conf E<lt>list optionE<gt>>
10019
10020 prints the current value of the I<list option> in MakeMaker's
10021 neatvalue format.
10022
10023 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
10024
10025 shifts or pops the array in the I<list option> variable
10026
10027 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
10028
10029 works like the corresponding perl commands.
10030
10031 =back
10032
10033 =head2 CPAN::anycwd($path): Note on config variable getcwd
10034
10035 CPAN.pm changes the current working directory often and needs to
10036 determine its own current working directory. Per default it uses
10037 Cwd::cwd but if this doesn't work on your system for some reason,
10038 alternatives can be configured according to the following table:
10039
10040 =over 2
10041
10042 =item cwd
10043
10044 Calls Cwd::cwd
10045
10046 =item getcwd
10047
10048 Calls Cwd::getcwd
10049
10050 =item fastcwd
10051
10052 Calls Cwd::fastcwd
10053
10054 =item backtickcwd
10055
10056 Calls the external command cwd.
10057
10058 =back
10059
10060 =head2 Note on the format of the urllist parameter
10061
10062 urllist parameters are URLs according to RFC 1738. We do a little
10063 guessing if your URL is not compliant, but if you have problems with
10064 C<file> URLs, please try the correct format. Either:
10065
10066     file://localhost/whatever/ftp/pub/CPAN/
10067
10068 or
10069
10070     file:///home/ftp/pub/CPAN/
10071
10072 =head2 urllist parameter has CD-ROM support
10073
10074 The C<urllist> parameter of the configuration table contains a list of
10075 URLs that are to be used for downloading. If the list contains any
10076 C<file> URLs, CPAN always tries to get files from there first. This
10077 feature is disabled for index files. So the recommendation for the
10078 owner of a CD-ROM with CPAN contents is: include your local, possibly
10079 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
10080
10081   o conf urllist push file://localhost/CDROM/CPAN
10082
10083 CPAN.pm will then fetch the index files from one of the CPAN sites
10084 that come at the beginning of urllist. It will later check for each
10085 module if there is a local copy of the most recent version.
10086
10087 Another peculiarity of urllist is that the site that we could
10088 successfully fetch the last file from automatically gets a preference
10089 token and is tried as the first site for the next request. So if you
10090 add a new site at runtime it may happen that the previously preferred
10091 site will be tried another time. This means that if you want to disallow
10092 a site for the next transfer, it must be explicitly removed from
10093 urllist.
10094
10095 =head2 Maintaining the urllist parameter
10096
10097 If you have YAML.pm (or some other YAML module configured in
10098 C<yaml_module>) installed, CPAN.pm collects a few statistical data
10099 about recent downloads. You can view the statistics with the C<hosts>
10100 command or inspect them directly by looking into the C<FTPstats.yml>
10101 file in your C<cpan_home> directory.
10102
10103 To get some interesting statistics it is recommended to set the
10104 C<randomize_urllist> parameter that introduces some amount of
10105 randomness into the URL selection.
10106
10107 =head2 prefs_dir for avoiding interactive questions (ALPHA)
10108
10109 (B<Note:> This feature has been introduced in CPAN.pm 1.8854 and is
10110 still considered experimental and may still be changed)
10111
10112 The files in the directory specified in C<prefs_dir> are YAML files
10113 that specify how CPAN.pm shall treat distributions that deviate from
10114 the normal non-interactive model of building and installing CPAN
10115 modules.
10116
10117 Some modules try to get some data from the user interactively thus
10118 disturbing the installation of large bundles like Phalanx100 or
10119 modules like Plagger.
10120
10121 CPAN.pm can use YAML files to either pass additional arguments to one
10122 of the four commands, set environment variables or instantiate an
10123 Expect object that reads from the console and enters answers on your
10124 behalf (latter option requires Expect.pm installed). A further option
10125 is to apply patches from the local disk or from CPAN.
10126
10127 CPAN.pm comes with a couple of such YAML files. The structure is
10128 currently not documented because in flux. Please see the distroprefs
10129 directory of the CPAN distribution for examples and follow the README
10130 in there.
10131
10132 Please note that setting the environment variable PERL_MM_USE_DEFAULT
10133 to a true value can also get you a long way if you want to always pick
10134 the default answers. But this only works if the author of a package
10135 used the prompt function provided by ExtUtils::MakeMaker and if the
10136 defaults are OK for you.
10137
10138 =head1 SECURITY
10139
10140 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
10141 install foreign, unmasked, unsigned code on your machine. We compare
10142 to a checksum that comes from the net just as the distribution file
10143 itself. But we try to make it easy to add security on demand:
10144
10145 =head2 Cryptographically signed modules
10146
10147 Since release 1.77 CPAN.pm has been able to verify cryptographically
10148 signed module distributions using Module::Signature.  The CPAN modules
10149 can be signed by their authors, thus giving more security.  The simple
10150 unsigned MD5 checksums that were used before by CPAN protect mainly
10151 against accidental file corruption.
10152
10153 You will need to have Module::Signature installed, which in turn
10154 requires that you have at least one of Crypt::OpenPGP module or the
10155 command-line F<gpg> tool installed.
10156
10157 You will also need to be able to connect over the Internet to the public
10158 keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
10159
10160 The configuration parameter check_sigs is there to turn signature
10161 checking on or off.
10162
10163 =head1 EXPORT
10164
10165 Most functions in package CPAN are exported per default. The reason
10166 for this is that the primary use is intended for the cpan shell or for
10167 one-liners.
10168
10169 =head1 ENVIRONMENT
10170
10171 When the CPAN shell enters a subshell via the look command, it sets
10172 the environment CPAN_SHELL_LEVEL to 1 or increments it if it is
10173 already set.
10174
10175 When CPAN runs, it sets the environment variable PERL5_CPAN_IS_RUNNING.
10176
10177 When the config variable ftp_passive is set, all downloads will be run
10178 with the environment variable FTP_PASSIVE set to this value. This is
10179 in general a good idea as it influences both Net::FTP and LWP based
10180 connections. The same effect can be achieved by starting the cpan
10181 shell with this environment variable set. For Net::FTP alone, one can
10182 also always set passive mode by running libnetcfg.
10183
10184 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
10185
10186 Populating a freshly installed perl with my favorite modules is pretty
10187 easy if you maintain a private bundle definition file. To get a useful
10188 blueprint of a bundle definition file, the command autobundle can be used
10189 on the CPAN shell command line. This command writes a bundle definition
10190 file for all modules that are installed for the currently running perl
10191 interpreter. It's recommended to run this command only once and from then
10192 on maintain the file manually under a private name, say
10193 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
10194
10195     cpan> install Bundle::my_bundle
10196
10197 then answer a few questions and then go out for a coffee.
10198
10199 Maintaining a bundle definition file means keeping track of two
10200 things: dependencies and interactivity. CPAN.pm sometimes fails on
10201 calculating dependencies because not all modules define all MakeMaker
10202 attributes correctly, so a bundle definition file should specify
10203 prerequisites as early as possible. On the other hand, it's a bit
10204 annoying that many distributions need some interactive configuring. So
10205 what I try to accomplish in my private bundle file is to have the
10206 packages that need to be configured early in the file and the gentle
10207 ones later, so I can go out after a few minutes and leave CPAN.pm
10208 untended.
10209
10210 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
10211
10212 Thanks to Graham Barr for contributing the following paragraphs about
10213 the interaction between perl, and various firewall configurations. For
10214 further information on firewalls, it is recommended to consult the
10215 documentation that comes with the ncftp program. If you are unable to
10216 go through the firewall with a simple Perl setup, it is very likely
10217 that you can configure ncftp so that it works for your firewall.
10218
10219 =head2 Three basic types of firewalls
10220
10221 Firewalls can be categorized into three basic types.
10222
10223 =over 4
10224
10225 =item http firewall
10226
10227 This is where the firewall machine runs a web server and to access the
10228 outside world you must do it via the web server. If you set environment
10229 variables like http_proxy or ftp_proxy to a values beginning with http://
10230 or in your web browser you have to set proxy information then you know
10231 you are running an http firewall.
10232
10233 To access servers outside these types of firewalls with perl (even for
10234 ftp) you will need to use LWP.
10235
10236 =item ftp firewall
10237
10238 This where the firewall machine runs an ftp server. This kind of
10239 firewall will only let you access ftp servers outside the firewall.
10240 This is usually done by connecting to the firewall with ftp, then
10241 entering a username like "user@outside.host.com"
10242
10243 To access servers outside these type of firewalls with perl you
10244 will need to use Net::FTP.
10245
10246 =item One way visibility
10247
10248 I say one way visibility as these firewalls try to make themselves look
10249 invisible to the users inside the firewall. An FTP data connection is
10250 normally created by sending the remote server your IP address and then
10251 listening for the connection. But the remote server will not be able to
10252 connect to you because of the firewall. So for these types of firewall
10253 FTP connections need to be done in a passive mode.
10254
10255 There are two that I can think off.
10256
10257 =over 4
10258
10259 =item SOCKS
10260
10261 If you are using a SOCKS firewall you will need to compile perl and link
10262 it with the SOCKS library, this is what is normally called a 'socksified'
10263 perl. With this executable you will be able to connect to servers outside
10264 the firewall as if it is not there.
10265
10266 =item IP Masquerade
10267
10268 This is the firewall implemented in the Linux kernel, it allows you to
10269 hide a complete network behind one IP address. With this firewall no
10270 special compiling is needed as you can access hosts directly.
10271
10272 For accessing ftp servers behind such firewalls you usually need to
10273 set the environment variable C<FTP_PASSIVE> or the config variable
10274 ftp_passive to a true value.
10275
10276 =back
10277
10278 =back
10279
10280 =head2 Configuring lynx or ncftp for going through a firewall
10281
10282 If you can go through your firewall with e.g. lynx, presumably with a
10283 command such as
10284
10285     /usr/local/bin/lynx -pscott:tiger
10286
10287 then you would configure CPAN.pm with the command
10288
10289     o conf lynx "/usr/local/bin/lynx -pscott:tiger"
10290
10291 That's all. Similarly for ncftp or ftp, you would configure something
10292 like
10293
10294     o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
10295
10296 Your mileage may vary...
10297
10298 =head1 FAQ
10299
10300 =over 4
10301
10302 =item 1)
10303
10304 I installed a new version of module X but CPAN keeps saying,
10305 I have the old version installed
10306
10307 Most probably you B<do> have the old version installed. This can
10308 happen if a module installs itself into a different directory in the
10309 @INC path than it was previously installed. This is not really a
10310 CPAN.pm problem, you would have the same problem when installing the
10311 module manually. The easiest way to prevent this behaviour is to add
10312 the argument C<UNINST=1> to the C<make install> call, and that is why
10313 many people add this argument permanently by configuring
10314
10315   o conf make_install_arg UNINST=1
10316
10317 =item 2)
10318
10319 So why is UNINST=1 not the default?
10320
10321 Because there are people who have their precise expectations about who
10322 may install where in the @INC path and who uses which @INC array. In
10323 fine tuned environments C<UNINST=1> can cause damage.
10324
10325 =item 3)
10326
10327 I want to clean up my mess, and install a new perl along with
10328 all modules I have. How do I go about it?
10329
10330 Run the autobundle command for your old perl and optionally rename the
10331 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
10332 with the Configure option prefix, e.g.
10333
10334     ./Configure -Dprefix=/usr/local/perl-5.6.78.9
10335
10336 Install the bundle file you produced in the first step with something like
10337
10338     cpan> install Bundle::mybundle
10339
10340 and you're done.
10341
10342 =item 4)
10343
10344 When I install bundles or multiple modules with one command
10345 there is too much output to keep track of.
10346
10347 You may want to configure something like
10348
10349   o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
10350   o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
10351
10352 so that STDOUT is captured in a file for later inspection.
10353
10354
10355 =item 5)
10356
10357 I am not root, how can I install a module in a personal directory?
10358
10359 First of all, you will want to use your own configuration, not the one
10360 that your root user installed. If you do not have permission to write
10361 in the cpan directory that root has configured, you will be asked if
10362 you want to create your own config. Answering "yes" will bring you into
10363 CPAN's configuration stage, using the system config for all defaults except
10364 things that have to do with CPAN's work directory, saving your choices to
10365 your MyConfig.pm file.
10366
10367 You can also manually initiate this process with the following command:
10368
10369     % perl -MCPAN -e 'mkmyconfig'
10370
10371 or by running
10372
10373     mkmyconfig
10374
10375 from the CPAN shell.
10376
10377 You will most probably also want to configure something like this:
10378
10379   o conf makepl_arg "LIB=~/myperl/lib \
10380                     INSTALLMAN1DIR=~/myperl/man/man1 \
10381                     INSTALLMAN3DIR=~/myperl/man/man3"
10382
10383 You can make this setting permanent like all C<o conf> settings with
10384 C<o conf commit>.
10385
10386 You will have to add ~/myperl/man to the MANPATH environment variable
10387 and also tell your perl programs to look into ~/myperl/lib, e.g. by
10388 including
10389
10390   use lib "$ENV{HOME}/myperl/lib";
10391
10392 or setting the PERL5LIB environment variable.
10393
10394 While we're speaking about $ENV{HOME}, it might be worth mentioning,
10395 that for Windows we use the File::HomeDir module that provides an
10396 equivalent to the concept of the home directory on Unix.
10397
10398 Another thing you should bear in mind is that the UNINST parameter can
10399 be dnagerous when you are installing into a private area because you
10400 might accidentally remove modules that other people depend on that are
10401 not using the private area.
10402
10403 =item 6)
10404
10405 How to get a package, unwrap it, and make a change before building it?
10406
10407 Have a look at the C<look> (!) command.
10408
10409 =item 7)
10410
10411 I installed a Bundle and had a couple of fails. When I
10412 retried, everything resolved nicely. Can this be fixed to work
10413 on first try?
10414
10415 The reason for this is that CPAN does not know the dependencies of all
10416 modules when it starts out. To decide about the additional items to
10417 install, it just uses data found in the META.yml file or the generated
10418 Makefile. An undetected missing piece breaks the process. But it may
10419 well be that your Bundle installs some prerequisite later than some
10420 depending item and thus your second try is able to resolve everything.
10421 Please note, CPAN.pm does not know the dependency tree in advance and
10422 cannot sort the queue of things to install in a topologically correct
10423 order. It resolves perfectly well IF all modules declare the
10424 prerequisites correctly with the PREREQ_PM attribute to MakeMaker or
10425 the C<requires> stanza of Module::Build. For bundles which fail and
10426 you need to install often, it is recommended to sort the Bundle
10427 definition file manually.
10428
10429 =item 8)
10430
10431 In our intranet we have many modules for internal use. How
10432 can I integrate these modules with CPAN.pm but without uploading
10433 the modules to CPAN?
10434
10435 Have a look at the CPAN::Site module.
10436
10437 =item 9)
10438
10439 When I run CPAN's shell, I get an error message about things in my
10440 /etc/inputrc (or ~/.inputrc) file.
10441
10442 These are readline issues and can only be fixed by studying readline
10443 configuration on your architecture and adjusting the referenced file
10444 accordingly. Please make a backup of the /etc/inputrc or ~/.inputrc
10445 and edit them. Quite often harmless changes like uppercasing or
10446 lowercasing some arguments solves the problem.
10447
10448 =item 10)
10449
10450 Some authors have strange characters in their names.
10451
10452 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
10453 expecting ISO-8859-1 charset, a converter can be activated by setting
10454 term_is_latin to a true value in your config file. One way of doing so
10455 would be
10456
10457     cpan> o conf term_is_latin 1
10458
10459 If other charset support is needed, please file a bugreport against
10460 CPAN.pm at rt.cpan.org and describe your needs. Maybe we can extend
10461 the support or maybe UTF-8 terminals become widely available.
10462
10463 =item 11)
10464
10465 When an install fails for some reason and then I correct the error
10466 condition and retry, CPAN.pm refuses to install the module, saying
10467 C<Already tried without success>.
10468
10469 Use the force pragma like so
10470
10471   force install Foo::Bar
10472
10473 This does a bit more than really needed because it untars the
10474 distribution again and runs make and test and only then install.
10475
10476 Or, if you find this is too fast and you would prefer to do smaller
10477 steps, say
10478
10479   force get Foo::Bar
10480
10481 first and then continue as always. C<Force get> I<forgets> previous
10482 error conditions.
10483
10484 Or you can use
10485
10486   look Foo::Bar
10487
10488 and then 'make install' directly in the subshell.
10489
10490 Or you leave the CPAN shell and start it again.
10491
10492 For the really curious, by accessing internals directly, you I<could>
10493
10494   !delete CPAN::Shell->expandany("Foo::Bar")->distribution->{install}
10495
10496 but this is neither guaranteed to work in the future nor is it a
10497 decent command.
10498
10499 =item 12)
10500
10501 How do I install a "DEVELOPER RELEASE" of a module?
10502
10503 By default, CPAN will install the latest non-developer release of a
10504 module. If you want to install a dev release, you have to specify the
10505 partial path starting with the author id to the tarball you wish to
10506 install, like so:
10507
10508     cpan> install KWILLIAMS/Module-Build-0.27_07.tar.gz
10509
10510 Note that you can use the C<ls> command to get this path listed.
10511
10512 =item 13)
10513
10514 How do I install a module and all its dependencies from the commandline,
10515 without being prompted for anything, despite my CPAN configuration
10516 (or lack thereof)?
10517
10518 CPAN uses ExtUtils::MakeMaker's prompt() function to ask its questions, so
10519 if you set the PERL_MM_USE_DEFAULT environment variable, you shouldn't be
10520 asked any questions at all (assuming the modules you are installing are
10521 nice about obeying that variable as well):
10522
10523     % PERL_MM_USE_DEFAULT=1 perl -MCPAN -e 'install My::Module'
10524
10525 =item 14)
10526
10527 How do I create a Module::Build based Build.PL derived from an
10528 ExtUtils::MakeMaker focused Makefile.PL?
10529
10530 http://search.cpan.org/search?query=Module::Build::Convert
10531
10532 http://accognoscere.org/papers/perl-module-build-convert/module-build-convert.html
10533
10534 =item 15)
10535
10536 What's the best CPAN site for me?
10537
10538 The urllist config parameter is yours. You can add and remove sites at
10539 will. You should find out which sites have the best uptodateness,
10540 bandwidth, reliability, etc. and are topologically close to you. Some
10541 people prefer fast downloads, others uptodateness, others reliability.
10542 You decide which to try in which order.
10543
10544 Henk P. Penning maintains a site that collects data about CPAN sites:
10545
10546   http://www.cs.uu.nl/people/henkp/mirmon/cpan.html
10547
10548 =back
10549
10550 =head1 BUGS
10551
10552 Please report bugs via http://rt.cpan.org/
10553
10554 Before submitting a bug, please make sure that the traditional method
10555 of building a Perl module package from a shell by following the
10556 installation instructions of that package still works in your
10557 environment.
10558
10559 =head1 SECURITY ADVICE
10560
10561 This software enables you to upgrade software on your computer and so
10562 is inherently dangerous because the newly installed software may
10563 contain bugs and may alter the way your computer works or even make it
10564 unusable. Please consider backing up your data before every upgrade.
10565
10566 =head1 AUTHOR
10567
10568 Andreas Koenig C<< <andk@cpan.org> >>
10569
10570 =head1 LICENSE
10571
10572 This program is free software; you can redistribute it and/or
10573 modify it under the same terms as Perl itself.
10574
10575 See L<http://www.perl.com/perl/misc/Artistic.html>
10576
10577 =head1 TRANSLATIONS
10578
10579 Kawai,Takanori provides a Japanese translation of this manpage at
10580 http://member.nifty.ne.jp/hippo2000/perltips/CPAN.htm
10581
10582 =head1 SEE ALSO
10583
10584 cpan(1), CPAN::Nox(3pm), CPAN::Version(3pm)
10585
10586 =cut