lib/CPAN.pm

   1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
   2 use strict;
   3 package CPAN;
   4 $CPAN::VERSION = '1.88_69';
   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              fforce
  98              get
  99              install
 100              install_tested
 101              make
 102              mkmyconfig
 103              notest
 104              perldoc
 105              readme
 106              recent
 107              recompile
 108              report
 109              shell
 110              test
 111              upgrade
 112             );
 113
 114 sub soft_chdir_with_alternatives ($);
 115
 116 {
 117     $autoload_recursion ||= 0;
 118
 119     #-> sub CPAN::AUTOLOAD ;
 120     sub AUTOLOAD {
 121         $autoload_recursion++;
 122         my($l) = $AUTOLOAD;
 123         $l =~ s/.*:://;
 124         if ($CPAN::Signal) {
 125             warn "Refusing to autoload '$l' while signal pending";
 126             $autoload_recursion--;
 127             return;
 128         }
 129         if ($autoload_recursion > 1) {
 130             my $fullcommand = join " ", map { "'$_'" } $l, @_;
 131             warn "Refusing to autoload $fullcommand in recursion\n";
 132             $autoload_recursion--;
 133             return;
 134         }
 135         my(%export);
 136         @export{@EXPORT} = '';
 137         CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 138         if (exists $export{$l}){
 139             CPAN::Shell->$l(@_);
 140         } else {
 141             die(qq{Unknown CPAN command "$AUTOLOAD". }.
 142                 qq{Type ? for help.\n});
 143         }
 144         $autoload_recursion--;
 145     }
 146 }
 147
 148 #-> sub CPAN::shell ;
 149 sub shell {
 150     my($self) = @_;
 151     $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
 152     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 153
 154     my $oprompt = shift || CPAN::Prompt->new;
 155     my $prompt = $oprompt;
 156     my $commandline = shift || "";
 157     $CPAN::CurrentCommandId ||= 1;
 158
 159     local($^W) = 1;
 160     unless ($Suppress_readline) {
 161         require Term::ReadLine;
 162         if (! $term
 163             or
 164             $term->ReadLine eq "Term::ReadLine::Stub"
 165            ) {
 166             $term = Term::ReadLine->new('CPAN Monitor');
 167         }
 168         if ($term->ReadLine eq "Term::ReadLine::Gnu") {
 169             my $attribs = $term->Attribs;
 170              $attribs->{attempted_completion_function} = sub {
 171                  &CPAN::Complete::gnu_cpl;
 172              }
 173         } else {
 174             $readline::rl_completion_function =
 175                 $readline::rl_completion_function = 'CPAN::Complete::cpl';
 176         }
 177         if (my $histfile = $CPAN::Config->{'histfile'}) {{
 178             unless ($term->can("AddHistory")) {
 179                 $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
 180                 last;
 181             }
 182             my($fh) = FileHandle->new;
 183             open $fh, "<$histfile" or last;
 184             local $/ = "\n";
 185             while (<$fh>) {
 186                 chomp;
 187                 $term->AddHistory($_);
 188             }
 189             close $fh;
 190         }}
 191         for ($CPAN::Config->{term_ornaments}) { # alias
 192             local $Term::ReadLine::termcap_nowarn = 1;
 193             $term->ornaments($_) if defined;
 194         }
 195         # $term->OUT is autoflushed anyway
 196         my $odef = select STDERR;
 197         $| = 1;
 198         select STDOUT;
 199         $| = 1;
 200         select $odef;
 201     }
 202
 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 ($@ && "$@" =~ /\S/){
 268                 require Carp;
 269                 Carp::cluck("Catching error: '$@'");
 270             }
 271             if ($command =~ /^(make|test|install|ff?orce|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 = _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             # this shall not be done by the frontend
 382             die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
 383         }
 384         return \@yaml;
 385     } else {
 386         # this shall not be done by the frontend
 387         die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "parse");
 388     }
 389     return +[];
 390 }
 391
 392 # CPAN::_yaml_dumpfile
 393 sub _yaml_dumpfile {
 394     my($self,$local_file,@what) = @_;
 395     my $yaml_module = _yaml_module;
 396     if ($CPAN::META->has_inst($yaml_module)) {
 397         if (UNIVERSAL::isa($local_file, "FileHandle")) {
 398             my $code = UNIVERSAL::can($yaml_module, "Dump");
 399             eval { print $local_file $code->(@what) };
 400         } else {
 401             my $code = UNIVERSAL::can($yaml_module, "DumpFile");
 402             eval { $code->($local_file,@what); };
 403         }
 404         if ($@) {
 405             die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"dump",$@);
 406         }
 407     } else {
 408         if (UNIVERSAL::isa($local_file, "FileHandle")) {
 409             # I think this case does not justify a warning at all
 410         } else {
 411             die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "dump");
 412         }
 413     }
 414 }
 415
 416 sub _init_sqlite () {
 417     unless ($CPAN::META->has_inst("CPAN::SQLite")) {
 418         $CPAN::Frontend->mywarn(qq{CPAN::SQLite not installed, trying to work without\n})
 419             unless $Have_warned->{"CPAN::SQLite"}++;
 420         return;
 421     }
 422     require CPAN::SQLite::META; # not needed since CVS version of 2006-12-17
 423     $CPAN::SQLite ||= CPAN::SQLite::META->new($CPAN::META);
 424 }
 425
 426 {
 427     my $negative_cache = {};
 428     sub _sqlite_running {
 429         if ($negative_cache->{time} && time < $negative_cache->{time} + 60) {
 430             # need to cache the result, otherwise too slow
 431             return $negative_cache->{fact};
 432         } else {
 433             $negative_cache = {}; # reset
 434         }
 435         my $ret = $CPAN::Config->{use_sqlite} && ($CPAN::SQLite || _init_sqlite());
 436         return $ret if $ret; # fast anyway
 437         $negative_cache->{time} = time;
 438         return $negative_cache->{fact} = $ret;
 439     }
 440 }
 441
 442 package CPAN::CacheMgr;
 443 use strict;
 444 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
 445 use File::Find;
 446
 447 package CPAN::FTP;
 448 use strict;
 449 use Fcntl qw(:flock);
 450 use vars qw($Ua $Thesite $ThesiteURL $Themethod);
 451 @CPAN::FTP::ISA = qw(CPAN::Debug);
 452
 453 package CPAN::LWP::UserAgent;
 454 use strict;
 455 use vars qw(@ISA $USER $PASSWD $SETUPDONE);
 456 # we delay requiring LWP::UserAgent and setting up inheritance until we need it
 457
 458 package CPAN::Complete;
 459 use strict;
 460 @CPAN::Complete::ISA = qw(CPAN::Debug);
 461 # Q: where is the "How do I add a new command" HOWTO?
 462 # A: svn diff -r 1048:1049 where andk added the report command
 463 @CPAN::Complete::COMMANDS = sort qw(
 464                                     ! a b d h i m o q r u
 465                                     autobundle
 466                                     clean
 467                                     cvs_import
 468                                     dump
 469                                     force
 470                                     fforce
 471                                     hosts
 472                                     install
 473                                     install_tested
 474                                     look
 475                                     ls
 476                                     make
 477                                     mkmyconfig
 478                                     notest
 479                                     perldoc
 480                                     readme
 481                                     recent
 482                                     recompile
 483                                     reload
 484                                     report
 485                                     scripts
 486                                     test
 487                                     upgrade
 488 );
 489
 490 package CPAN::Index;
 491 use strict;
 492 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED);
 493 @CPAN::Index::ISA = qw(CPAN::Debug);
 494 $LAST_TIME ||= 0;
 495 $DATE_OF_03 ||= 0;
 496 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
 497 sub PROTOCOL { 2.0 }
 498
 499 package CPAN::InfoObj;
 500 use strict;
 501 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
 502
 503 package CPAN::Author;
 504 use strict;
 505 @CPAN::Author::ISA = qw(CPAN::InfoObj);
 506
 507 package CPAN::Distribution;
 508 use strict;
 509 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
 510
 511 package CPAN::Bundle;
 512 use strict;
 513 @CPAN::Bundle::ISA = qw(CPAN::Module);
 514
 515 package CPAN::Module;
 516 use strict;
 517 @CPAN::Module::ISA = qw(CPAN::InfoObj);
 518
 519 package CPAN::Exception::RecursiveDependency;
 520 use strict;
 521 use overload '""' => "as_string";
 522
 523 sub new {
 524     my($class) = shift;
 525     my($deps) = shift;
 526     my @deps;
 527     my %seen;
 528     for my $dep (@$deps) {
 529         push @deps, $dep;
 530         last if $seen{$dep}++;
 531     }
 532     bless { deps => \@deps }, $class;
 533 }
 534
 535 sub as_string {
 536     my($self) = shift;
 537     "\nRecursive dependency detected:\n    " .
 538         join("\n => ", @{$self->{deps}}) .
 539             ".\nCannot continue.\n";
 540 }
 541
 542 package CPAN::Exception::yaml_not_installed;
 543 use strict;
 544 use overload '""' => "as_string";
 545
 546 sub new {
 547     my($class,$module,$file,$during) = @_;
 548     bless { module => $module, file => $file, during => $during }, $class;
 549 }
 550
 551 sub as_string {
 552     my($self) = shift;
 553     "'$self->{module}' not installed, cannot $self->{during} '$self->{file}'\n";
 554 }
 555
 556 package CPAN::Exception::yaml_process_error;
 557 use strict;
 558 use overload '""' => "as_string";
 559
 560 sub new {
 561     my($class,$module,$file,$during,$error) = shift;
 562     bless { module => $module,
 563             file => $file,
 564             during => $during,
 565             error => $error }, $class;
 566 }
 567
 568 sub as_string {
 569     my($self) = shift;
 570     "Alert: While trying to $self->{during} YAML file\n".
 571         "  $self->{file}\n".
 572             "with '$self->{module}' the following error was encountered:\n".
 573                 "  $self->{error}\n";
 574 }
 575
 576 package CPAN::Prompt; use overload '""' => "as_string";
 577 use vars qw($prompt);
 578 $prompt = "cpan> ";
 579 $CPAN::CurrentCommandId ||= 0;
 580 sub new {
 581     bless {}, shift;
 582 }
 583 sub as_string {
 584     my $word = "cpan";
 585     unless ($CPAN::META->{LOCK}) {
 586         $word = "nolock_cpan";
 587     }
 588     if ($CPAN::Config->{commandnumber_in_prompt}) {
 589         sprintf "$word\[%d]> ", $CPAN::CurrentCommandId;
 590     } else {
 591         "$word> ";
 592     }
 593 }
 594
 595 package CPAN::URL; use overload '""' => "as_string", fallback => 1;
 596 # accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist),
 597 # planned are things like age or quality
 598 sub new {
 599     my($class,%args) = @_;
 600     bless {
 601            %args
 602           }, $class;
 603 }
 604 sub as_string {
 605     my($self) = @_;
 606     $self->text;
 607 }
 608 sub text {
 609     my($self,$set) = @_;
 610     if (defined $set) {
 611         $self->{TEXT} = $set;
 612     }
 613     $self->{TEXT};
 614 }
 615
 616 package CPAN::Distrostatus;
 617 use overload '""' => "as_string",
 618     fallback => 1;
 619 sub new {
 620     my($class,$arg) = @_;
 621     bless {
 622            TEXT => $arg,
 623            FAILED => substr($arg,0,2) eq "NO",
 624            COMMANDID => $CPAN::CurrentCommandId,
 625            TIME => time,
 626           }, $class;
 627 }
 628 sub commandid { shift->{COMMANDID} }
 629 sub failed { shift->{FAILED} }
 630 sub text {
 631     my($self,$set) = @_;
 632     if (defined $set) {
 633         $self->{TEXT} = $set;
 634     }
 635     $self->{TEXT};
 636 }
 637 sub as_string {
 638     my($self) = @_;
 639     $self->text;
 640 }
 641
 642 package CPAN::Shell;
 643 use strict;
 644 use vars qw(
 645             $ADVANCED_QUERY
 646             $AUTOLOAD
 647             $COLOR_REGISTERED
 648             $autoload_recursion
 649             $reload
 650             @ISA
 651            );
 652 @CPAN::Shell::ISA = qw(CPAN::Debug);
 653 $COLOR_REGISTERED ||= 0;
 654
 655 {
 656     $autoload_recursion   ||= 0;
 657
 658     #-> sub CPAN::Shell::AUTOLOAD ;
 659     sub AUTOLOAD {
 660         $autoload_recursion++;
 661         my($l) = $AUTOLOAD;
 662         my $class = shift(@_);
 663         # warn "autoload[$l] class[$class]";
 664         $l =~ s/.*:://;
 665         if ($CPAN::Signal) {
 666             warn "Refusing to autoload '$l' while signal pending";
 667             $autoload_recursion--;
 668             return;
 669         }
 670         if ($autoload_recursion > 1) {
 671             my $fullcommand = join " ", map { "'$_'" } $l, @_;
 672             warn "Refusing to autoload $fullcommand in recursion\n";
 673             $autoload_recursion--;
 674             return;
 675         }
 676         if ($l =~ /^w/) {
 677             # XXX needs to be reconsidered
 678             if ($CPAN::META->has_inst('CPAN::WAIT')) {
 679                 CPAN::WAIT->$l(@_);
 680             } else {
 681                 $CPAN::Frontend->mywarn(qq{
 682 Commands starting with "w" require CPAN::WAIT to be installed.
 683 Please consider installing CPAN::WAIT to use the fulltext index.
 684 For this you just need to type
 685     install CPAN::WAIT
 686 });
 687             }
 688         } else {
 689             $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }.
 690                                     qq{Type ? for help.
 691 });
 692         }
 693         $autoload_recursion--;
 694     }
 695 }
 696
 697 package CPAN;
 698 use strict;
 699
 700 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
 701
 702 # from here on only subs.
 703 ################################################################################
 704
 705 sub _perl_fingerprint {
 706     my($self,$other_fingerprint) = @_;
 707     my $dll = eval {OS2::DLLname()};
 708     my $mtime_dll = 0;
 709     if (defined $dll) {
 710         $mtime_dll = (-f $dll ? (stat(_))[9] : '-1');
 711     }
 712     my $this_fingerprint = {
 713                             '$^X' => $^X,
 714                             sitearchexp => $Config::Config{sitearchexp},
 715                             'mtime_$^X' => (stat $^X)[9],
 716                             'mtime_dll' => $mtime_dll,
 717                            };
 718     if ($other_fingerprint) {
 719         if (exists $other_fingerprint->{'stat($^X)'}) { # repair fp from rev. 1.88_57
 720             $other_fingerprint->{'mtime_$^X'} = $other_fingerprint->{'stat($^X)'}[9];
 721         }
 722         # mandatory keys since 1.88_57
 723         for my $key (qw($^X sitearchexp mtime_dll mtime_$^X)) {
 724             return unless $other_fingerprint->{$key} eq $this_fingerprint->{$key};
 725         }
 726         return 1;
 727     } else {
 728         return $this_fingerprint;
 729     }
 730 }
 731
 732 sub suggest_myconfig () {
 733   SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) {
 734         $CPAN::Frontend->myprint("You don't seem to have a user ".
 735                                  "configuration (MyConfig.pm) yet.\n");
 736         my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ".
 737                                               "user configuration now? (Y/n)",
 738                                               "yes");
 739         if($new =~ m{^y}i) {
 740             CPAN::Shell->mkmyconfig();
 741             return &checklock;
 742         } else {
 743             $CPAN::Frontend->mydie("OK, giving up.");
 744         }
 745     }
 746 }
 747
 748 #-> sub CPAN::all_objects ;
 749 sub all_objects {
 750     my($mgr,$class) = @_;
 751     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 752     CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
 753     CPAN::Index->reload;
 754     values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
 755 }
 756
 757 # Called by shell, not in batch mode. In batch mode I see no risk in
 758 # having many processes updating something as installations are
 759 # continually checked at runtime. In shell mode I suspect it is
 760 # unintentional to open more than one shell at a time
 761
 762 #-> sub CPAN::checklock ;
 763 sub checklock {
 764     my($self) = @_;
 765     my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
 766     if (-f $lockfile && -M _ > 0) {
 767         my $fh = FileHandle->new($lockfile) or
 768             $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
 769         my $otherpid  = <$fh>;
 770         my $otherhost = <$fh>;
 771         $fh->close;
 772         if (defined $otherpid && $otherpid) {
 773             chomp $otherpid;
 774         }
 775         if (defined $otherhost && $otherhost) {
 776             chomp $otherhost;
 777         }
 778         my $thishost  = hostname();
 779         if (defined $otherhost && defined $thishost &&
 780             $otherhost ne '' && $thishost ne '' &&
 781             $otherhost ne $thishost) {
 782             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
 783                                            "reports other host $otherhost and other ".
 784                                            "process $otherpid.\n".
 785                                            "Cannot proceed.\n"));
 786         } elsif ($RUN_DEGRADED) {
 787             $CPAN::Frontend->mywarn("Running in degraded mode (experimental)\n");
 788         } elsif (defined $otherpid && $otherpid) {
 789             return if $$ == $otherpid; # should never happen
 790             $CPAN::Frontend->mywarn(
 791                                     qq{
 792 There seems to be running another CPAN process (pid $otherpid).  Contacting...
 793 });
 794             if (kill 0, $otherpid) {
 795                 $CPAN::Frontend->mywarn(qq{Other job is running.\n});
 796                 my($ans) =
 797                     CPAN::Shell::colorable_makemaker_prompt
 798                         (qq{Shall I try to run in degraded }.
 799                          qq{mode? (Y/n)},"y");
 800                 if ($ans =~ /^y/i) {
 801                     $CPAN::Frontend->mywarn("Running in degraded mode (experimental).
 802 Please report if something unexpected happens\n");
 803                     $RUN_DEGRADED = 1;
 804                     for ($CPAN::Config) {
 805                         # XXX
 806                         # $_->{build_dir_reuse} = 0; # 2006-11-17 akoenig Why was that?
 807                         $_->{commandnumber_in_prompt} = 0; # visibility
 808                         $_->{histfile} = "";               # who should win otherwise?
 809                         $_->{cache_metadata} = 0;          # better would be a lock?
 810                         $_->{use_sqlite} = 0;              # better would be a write lock!
 811                     }
 812                 } else {
 813                     $CPAN::Frontend->mydie("
 814 You may want to kill the other job and delete the lockfile. On UNIX try:
 815     kill $otherpid
 816     rm $lockfile
 817 ");
 818                 }
 819             } elsif (-w $lockfile) {
 820                 my($ans) =
 821                     CPAN::Shell::colorable_makemaker_prompt
 822                         (qq{Other job not responding. Shall I overwrite }.
 823                          qq{the lockfile '$lockfile'? (Y/n)},"y");
 824                 $CPAN::Frontend->myexit("Ok, bye\n")
 825                     unless $ans =~ /^y/i;
 826             } else {
 827                 Carp::croak(
 828                             qq{Lockfile '$lockfile' not writeable by you. }.
 829                             qq{Cannot proceed.\n}.
 830                             qq{    On UNIX try:\n}.
 831                             qq{    rm '$lockfile'\n}.
 832                             qq{  and then rerun us.\n}
 833                            );
 834             }
 835         } else {
 836             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Found invalid lockfile ".
 837                                            "'$lockfile', please remove. Cannot proceed.\n"));
 838         }
 839     }
 840     my $dotcpan = $CPAN::Config->{cpan_home};
 841     eval { File::Path::mkpath($dotcpan);};
 842     if ($@) {
 843         # A special case at least for Jarkko.
 844         my $firsterror = $@;
 845         my $seconderror;
 846         my $symlinkcpan;
 847         if (-l $dotcpan) {
 848             $symlinkcpan = readlink $dotcpan;
 849             die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
 850             eval { File::Path::mkpath($symlinkcpan); };
 851             if ($@) {
 852                 $seconderror = $@;
 853             } else {
 854                 $CPAN::Frontend->mywarn(qq{
 855 Working directory $symlinkcpan created.
 856 });
 857             }
 858         }
 859         unless (-d $dotcpan) {
 860             my $mess = qq{
 861 Your configuration suggests "$dotcpan" as your
 862 CPAN.pm working directory. I could not create this directory due
 863 to this error: $firsterror\n};
 864             $mess .= qq{
 865 As "$dotcpan" is a symlink to "$symlinkcpan",
 866 I tried to create that, but I failed with this error: $seconderror
 867 } if $seconderror;
 868             $mess .= qq{
 869 Please make sure the directory exists and is writable.
 870 };
 871             $CPAN::Frontend->myprint($mess);
 872             return suggest_myconfig;
 873         }
 874     } # $@ after eval mkpath $dotcpan
 875     if (0) { # to test what happens when a race condition occurs
 876         for (reverse 1..10) {
 877             print $_, "\n";
 878             sleep 1;
 879         }
 880     }
 881     # locking
 882     if (!$RUN_DEGRADED && !$self->{LOCKFH}) {
 883         my $fh;
 884         unless ($fh = FileHandle->new("+>>$lockfile")) {
 885             if ($! =~ /Permission/) {
 886                 $CPAN::Frontend->myprint(qq{
 887
 888 Your configuration suggests that CPAN.pm should use a working
 889 directory of
 890     $CPAN::Config->{cpan_home}
 891 Unfortunately we could not create the lock file
 892     $lockfile
 893 due to permission problems.
 894
 895 Please make sure that the configuration variable
 896     \$CPAN::Config->{cpan_home}
 897 points to a directory where you can write a .lock file. You can set
 898 this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
 899 \@INC path;
 900 });
 901                 return suggest_myconfig;
 902             }
 903         }
 904         my $sleep = 1;
 905         while (!flock $fh, LOCK_EX|LOCK_NB) {
 906             if ($sleep>10) {
 907                 $CPAN::Frontend->mydie("Giving up\n");
 908             }
 909             $CPAN::Frontend->mysleep($sleep++);
 910             $CPAN::Frontend->mywarn("Could not lock lockfile with flock: $!; retrying\n");
 911         }
 912
 913         seek $fh, 0, 0;
 914         truncate $fh, 0;
 915         $fh->print($$, "\n");
 916         $fh->print(hostname(), "\n");
 917         $self->{LOCK} = $lockfile;
 918         $self->{LOCKFH} = $fh;
 919     }
 920     $SIG{TERM} = sub {
 921         my $sig = shift;
 922         &cleanup;
 923         $CPAN::Frontend->mydie("Got SIG$sig, leaving");
 924     };
 925     $SIG{INT} = sub {
 926       # no blocks!!!
 927         my $sig = shift;
 928         &cleanup if $Signal;
 929         die "Got yet another signal" if $Signal > 1;
 930         $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal;
 931         $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n");
 932         $Signal++;
 933     };
 934
 935 #       From: Larry Wall <larry@wall.org>
 936 #       Subject: Re: deprecating SIGDIE
 937 #       To: perl5-porters@perl.org
 938 #       Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
 939 #
 940 #       The original intent of __DIE__ was only to allow you to substitute one
 941 #       kind of death for another on an application-wide basis without respect
 942 #       to whether you were in an eval or not.  As a global backstop, it should
 943 #       not be used any more lightly (or any more heavily :-) than class
 944 #       UNIVERSAL.  Any attempt to build a general exception model on it should
 945 #       be politely squashed.  Any bug that causes every eval {} to have to be
 946 #       modified should be not so politely squashed.
 947 #
 948 #       Those are my current opinions.  It is also my optinion that polite
 949 #       arguments degenerate to personal arguments far too frequently, and that
 950 #       when they do, it's because both people wanted it to, or at least didn't
 951 #       sufficiently want it not to.
 952 #
 953 #       Larry
 954
 955     # global backstop to cleanup if we should really die
 956     $SIG{__DIE__} = \&cleanup;
 957     $self->debug("Signal handler set.") if $CPAN::DEBUG;
 958 }
 959
 960 #-> sub CPAN::DESTROY ;
 961 sub DESTROY {
 962     &cleanup; # need an eval?
 963 }
 964
 965 #-> sub CPAN::anycwd ;
 966 sub anycwd () {
 967     my $getcwd;
 968     $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
 969     CPAN->$getcwd();
 970 }
 971
 972 #-> sub CPAN::cwd ;
 973 sub cwd {Cwd::cwd();}
 974
 975 #-> sub CPAN::getcwd ;
 976 sub getcwd {Cwd::getcwd();}
 977
 978 #-> sub CPAN::fastcwd ;
 979 sub fastcwd {Cwd::fastcwd();}
 980
 981 #-> sub CPAN::backtickcwd ;
 982 sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
 983
 984 #-> sub CPAN::find_perl ;
 985 sub find_perl {
 986     my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
 987     my $pwd  = $CPAN::iCwd = CPAN::anycwd();
 988     my $candidate = File::Spec->catfile($pwd,$^X);
 989     $perl ||= $candidate if MM->maybe_command($candidate);
 990
 991     unless ($perl) {
 992         my ($component,$perl_name);
 993       DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
 994             PATH_COMPONENT: foreach $component (File::Spec->path(),
 995                                                 $Config::Config{'binexp'}) {
 996                   next unless defined($component) && $component;
 997                   my($abs) = File::Spec->catfile($component,$perl_name);
 998                   if (MM->maybe_command($abs)) {
 999                       $perl = $abs;
1000                       last DIST_PERLNAME;
1001                   }
1002               }
1003           }
1004     }
1005
1006     return $perl;
1007 }
1008
1009
1010 #-> sub CPAN::exists ;
1011 sub exists {
1012     my($mgr,$class,$id) = @_;
1013     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
1014     CPAN::Index->reload;
1015     ### Carp::croak "exists called without class argument" unless $class;
1016     $id ||= "";
1017     $id =~ s/:+/::/g if $class eq "CPAN::Module";
1018     my $exists;
1019     if (CPAN::_sqlite_running) {
1020         $exists = (exists $META->{readonly}{$class}{$id} or
1021                    $CPAN::SQLite->set($class, $id));
1022     } else {
1023         $exists =  exists $META->{readonly}{$class}{$id};
1024     }
1025     $exists ||= exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
1026 }
1027
1028 #-> sub CPAN::delete ;
1029 sub delete {
1030   my($mgr,$class,$id) = @_;
1031   delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
1032   delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
1033 }
1034
1035 #-> sub CPAN::has_usable
1036 # has_inst is sometimes too optimistic, we should replace it with this
1037 # has_usable whenever a case is given
1038 sub has_usable {
1039     my($self,$mod,$message) = @_;
1040     return 1 if $HAS_USABLE->{$mod};
1041     my $has_inst = $self->has_inst($mod,$message);
1042     return unless $has_inst;
1043     my $usable;
1044     $usable = {
1045                LWP => [ # we frequently had "Can't locate object
1046                         # method "new" via package "LWP::UserAgent" at
1047                         # (eval 69) line 2006
1048                        sub {require LWP},
1049                        sub {require LWP::UserAgent},
1050                        sub {require HTTP::Request},
1051                        sub {require URI::URL},
1052                       ],
1053                'Net::FTP' => [
1054                             sub {require Net::FTP},
1055                             sub {require Net::Config},
1056                            ],
1057                'File::HomeDir' => [
1058                                    sub {require File::HomeDir;
1059                                         unless (File::HomeDir::->VERSION >= 0.52){
1060                                             for ("Will not use File::HomeDir, need 0.52\n") {
1061                                                 $CPAN::Frontend->mywarn($_);
1062                                                 die $_;
1063                                             }
1064                                         }
1065                                     },
1066                                   ],
1067               };
1068     if ($usable->{$mod}) {
1069         for my $c (0..$#{$usable->{$mod}}) {
1070             my $code = $usable->{$mod}[$c];
1071             my $ret = eval { &$code() };
1072             $ret = "" unless defined $ret;
1073             if ($@) {
1074                 # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
1075                 return;
1076             }
1077         }
1078     }
1079     return $HAS_USABLE->{$mod} = 1;
1080 }
1081
1082 #-> sub CPAN::has_inst
1083 sub has_inst {
1084     my($self,$mod,$message) = @_;
1085     Carp::croak("CPAN->has_inst() called without an argument")
1086         unless defined $mod;
1087     my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
1088         keys %{$CPAN::Config->{dontload_hash}||{}},
1089             @{$CPAN::Config->{dontload_list}||[]};
1090     if (defined $message && $message eq "no"  # afair only used by Nox
1091         ||
1092         $dont{$mod}
1093        ) {
1094       $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
1095       return 0;
1096     }
1097     my $file = $mod;
1098     my $obj;
1099     $file =~ s|::|/|g;
1100     $file .= ".pm";
1101     if ($INC{$file}) {
1102         # checking %INC is wrong, because $INC{LWP} may be true
1103         # although $INC{"URI/URL.pm"} may have failed. But as
1104         # I really want to say "bla loaded OK", I have to somehow
1105         # cache results.
1106         ### warn "$file in %INC"; #debug
1107         return 1;
1108     } elsif (eval { require $file }) {
1109         # eval is good: if we haven't yet read the database it's
1110         # perfect and if we have installed the module in the meantime,
1111         # it tries again. The second require is only a NOOP returning
1112         # 1 if we had success, otherwise it's retrying
1113
1114         my $v = eval "\$$mod\::VERSION";
1115         $v = $v ? " (v$v)" : "";
1116         $CPAN::Frontend->myprint("CPAN: $mod loaded ok$v\n");
1117         if ($mod eq "CPAN::WAIT") {
1118             push @CPAN::Shell::ISA, 'CPAN::WAIT';
1119         }
1120         return 1;
1121     } elsif ($mod eq "Net::FTP") {
1122         $CPAN::Frontend->mywarn(qq{
1123   Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
1124   if you just type
1125       install Bundle::libnet
1126
1127 }) unless $Have_warned->{"Net::FTP"}++;
1128         $CPAN::Frontend->mysleep(3);
1129     } elsif ($mod eq "Digest::SHA"){
1130         if ($Have_warned->{"Digest::SHA"}++) {
1131             $CPAN::Frontend->myprint(qq{CPAN: checksum security checks disabled}.
1132                                      qq{because Digest::SHA not installed.\n});
1133         } else {
1134             $CPAN::Frontend->mywarn(qq{
1135   CPAN: checksum security checks disabled because Digest::SHA not installed.
1136   Please consider installing the Digest::SHA module.
1137
1138 });
1139             $CPAN::Frontend->mysleep(2);
1140         }
1141     } elsif ($mod eq "Module::Signature"){
1142         # NOT prefs_lookup, we are not a distro
1143         my $check_sigs = $CPAN::Config->{check_sigs};
1144         if (not $check_sigs) {
1145             # they do not want us:-(
1146         } elsif (not $Have_warned->{"Module::Signature"}++) {
1147             # No point in complaining unless the user can
1148             # reasonably install and use it.
1149             if (eval { require Crypt::OpenPGP; 1 } ||
1150                 (
1151                  defined $CPAN::Config->{'gpg'}
1152                  &&
1153                  $CPAN::Config->{'gpg'} =~ /\S/
1154                 )
1155                ) {
1156                 $CPAN::Frontend->mywarn(qq{
1157   CPAN: Module::Signature security checks disabled because Module::Signature
1158   not installed.  Please consider installing the Module::Signature module.
1159   You may also need to be able to connect over the Internet to the public
1160   keyservers like pgp.mit.edu (port 11371).
1161
1162 });
1163                 $CPAN::Frontend->mysleep(2);
1164             }
1165         }
1166     } else {
1167         delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
1168     }
1169     return 0;
1170 }
1171
1172 #-> sub CPAN::instance ;
1173 sub instance {
1174     my($mgr,$class,$id) = @_;
1175     CPAN::Index->reload;
1176     $id ||= "";
1177     # unsafe meta access, ok?
1178     return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
1179     $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
1180 }
1181
1182 #-> sub CPAN::new ;
1183 sub new {
1184     bless {}, shift;
1185 }
1186
1187 #-> sub CPAN::cleanup ;
1188 sub cleanup {
1189   # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
1190   local $SIG{__DIE__} = '';
1191   my($message) = @_;
1192   my $i = 0;
1193   my $ineval = 0;
1194   my($subroutine);
1195   while ((undef,undef,undef,$subroutine) = caller(++$i)) {
1196       $ineval = 1, last if
1197           $subroutine eq '(eval)';
1198   }
1199   return if $ineval && !$CPAN::End;
1200   return unless defined $META->{LOCK};
1201   return unless -f $META->{LOCK};
1202   $META->savehist;
1203   close $META->{LOCKFH};
1204   unlink $META->{LOCK};
1205   # require Carp;
1206   # Carp::cluck("DEBUGGING");
1207   if ( $CPAN::CONFIG_DIRTY ) {
1208       $CPAN::Frontend->mywarn("Warning: Configuration not saved.\n");
1209   }
1210   $CPAN::Frontend->myprint("Lockfile removed.\n");
1211 }
1212
1213 #-> sub CPAN::savehist
1214 sub savehist {
1215     my($self) = @_;
1216     my($histfile,$histsize);
1217     unless ($histfile = $CPAN::Config->{'histfile'}){
1218         $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
1219         return;
1220     }
1221     $histsize = $CPAN::Config->{'histsize'} || 100;
1222     if ($CPAN::term){
1223         unless ($CPAN::term->can("GetHistory")) {
1224             $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
1225             return;
1226         }
1227     } else {
1228         return;
1229     }
1230     my @h = $CPAN::term->GetHistory;
1231     splice @h, 0, @h-$histsize if @h>$histsize;
1232     my($fh) = FileHandle->new;
1233     open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
1234     local $\ = local $, = "\n";
1235     print $fh @h;
1236     close $fh;
1237 }
1238
1239 #-> sub CPAN::is_tested
1240 sub is_tested {
1241     my($self,$what,$when) = @_;
1242     unless ($what) {
1243         Carp::cluck("DEBUG: empty what");
1244         return;
1245     }
1246     $self->{is_tested}{$what} = $when;
1247 }
1248
1249 #-> sub CPAN::is_installed
1250 # unsets the is_tested flag: as soon as the thing is installed, it is
1251 # not needed in set_perl5lib anymore
1252 sub is_installed {
1253     my($self,$what) = @_;
1254     delete $self->{is_tested}{$what};
1255 }
1256
1257 sub _list_sorted_descending_is_tested {
1258     my($self) = @_;
1259     sort
1260         { ($self->{is_tested}{$b}||0) <=> ($self->{is_tested}{$a}||0) }
1261             keys %{$self->{is_tested}}
1262 }
1263
1264 #-> sub CPAN::set_perl5lib
1265 sub set_perl5lib {
1266     my($self,$for) = @_;
1267     unless ($for) {
1268         (undef,undef,undef,$for) = caller(1);
1269         $for =~ s/.*://;
1270     }
1271     $self->{is_tested} ||= {};
1272     return unless %{$self->{is_tested}};
1273     my $env = $ENV{PERL5LIB};
1274     $env = $ENV{PERLLIB} unless defined $env;
1275     my @env;
1276     push @env, $env if defined $env and length $env;
1277     #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
1278     #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
1279
1280     my @dirs = map {("$_/blib/arch", "$_/blib/lib")} $self->_list_sorted_descending_is_tested;
1281     if (@dirs < 12) {
1282         $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB for '$for'\n");
1283     } elsif (@dirs < 24) {
1284         my @d = map {my $cp = $_;
1285                      $cp =~ s/^\Q$CPAN::Config->{build_dir}\E/%BUILDDIR%/;
1286                      $cp
1287                  } @dirs;
1288         $CPAN::Frontend->myprint("Prepending @d to PERL5LIB; ".
1289                                  "%BUILDDIR%=$CPAN::Config->{build_dir} ".
1290                                  "for '$for'\n"
1291                                 );
1292     } else {
1293         my $cnt = keys %{$self->{is_tested}};
1294         $CPAN::Frontend->myprint("Prepending blib/arch and blib/lib of ".
1295                                  "$cnt build dirs to PERL5LIB; ".
1296                                  "for '$for'\n"
1297                                 );
1298     }
1299
1300     $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1301 }
1302
1303 package CPAN::CacheMgr;
1304 use strict;
1305
1306 #-> sub CPAN::CacheMgr::as_string ;
1307 sub as_string {
1308     eval { require Data::Dumper };
1309     if ($@) {
1310         return shift->SUPER::as_string;
1311     } else {
1312         return Data::Dumper::Dumper(shift);
1313     }
1314 }
1315
1316 #-> sub CPAN::CacheMgr::cachesize ;
1317 sub cachesize {
1318     shift->{DU};
1319 }
1320
1321 #-> sub CPAN::CacheMgr::tidyup ;
1322 sub tidyup {
1323   my($self) = @_;
1324   return unless $CPAN::META->{LOCK};
1325   return unless -d $self->{ID};
1326   while ($self->{DU} > $self->{'MAX'} ) {
1327     my($toremove) = shift @{$self->{FIFO}};
1328     unless ($toremove =~ /\.yml$/) {
1329         $CPAN::Frontend->myprint(sprintf(
1330                                          "DEL: $toremove (%.1f>%.1f MB)\n",
1331                                          $self->{DU}, $self->{'MAX'})
1332                                 );
1333     }
1334     return if $CPAN::Signal;
1335     $self->_clean_cache($toremove);
1336     return if $CPAN::Signal;
1337   }
1338 }
1339
1340 #-> sub CPAN::CacheMgr::dir ;
1341 sub dir {
1342     shift->{ID};
1343 }
1344
1345 #-> sub CPAN::CacheMgr::entries ;
1346 sub entries {
1347     my($self,$dir) = @_;
1348     return unless defined $dir;
1349     $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
1350     $dir ||= $self->{ID};
1351     my($cwd) = CPAN::anycwd();
1352     chdir $dir or Carp::croak("Can't chdir to $dir: $!");
1353     my $dh = DirHandle->new(File::Spec->curdir)
1354         or Carp::croak("Couldn't opendir $dir: $!");
1355     my(@entries);
1356     for ($dh->read) {
1357         next if $_ eq "." || $_ eq "..";
1358         if (-f $_) {
1359             push @entries, File::Spec->catfile($dir,$_);
1360         } elsif (-d _) {
1361             push @entries, File::Spec->catdir($dir,$_);
1362         } else {
1363             $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
1364         }
1365     }
1366     chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
1367     sort { -M $b <=> -M $a} @entries;
1368 }
1369
1370 #-> sub CPAN::CacheMgr::disk_usage ;
1371 sub disk_usage {
1372     my($self,$dir) = @_;
1373     return if exists $self->{SIZE}{$dir};
1374     return if $CPAN::Signal;
1375     my($Du) = 0;
1376     if (-e $dir) {
1377         unless (-x $dir) {
1378             unless (chmod 0755, $dir) {
1379                 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
1380                                         "permission to change the permission; cannot ".
1381                                         "estimate disk usage of '$dir'\n");
1382                 $CPAN::Frontend->mysleep(5);
1383                 return;
1384             }
1385         }
1386     } else {
1387         $CPAN::Frontend->mywarn("Directory '$dir' has gone. Cannot continue.\n");
1388         return;
1389     }
1390     find(
1391          sub {
1392            $File::Find::prune++ if $CPAN::Signal;
1393            return if -l $_;
1394            if ($^O eq 'MacOS') {
1395              require Mac::Files;
1396              my $cat  = Mac::Files::FSpGetCatInfo($_);
1397              $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
1398            } else {
1399              if (-d _) {
1400                unless (-x _) {
1401                  unless (chmod 0755, $_) {
1402                    $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
1403                                            "the permission to change the permission; ".
1404                                            "can only partially estimate disk usage ".
1405                                            "of '$_'\n");
1406                    $CPAN::Frontend->mysleep(5);
1407                    return;
1408                  }
1409                }
1410              } else {
1411                $Du += (-s _);
1412              }
1413            }
1414          },
1415          $dir
1416         );
1417     return if $CPAN::Signal;
1418     $self->{SIZE}{$dir} = $Du/1024/1024;
1419     push @{$self->{FIFO}}, $dir;
1420     $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
1421     $self->{DU} += $Du/1024/1024;
1422     $self->{DU};
1423 }
1424
1425 #-> sub CPAN::CacheMgr::_clean_cache ;
1426 sub _clean_cache {
1427     my($self,$dir) = @_;
1428     return unless -e $dir;
1429     unless (File::Spec->canonpath(File::Basename::dirname($dir))
1430             eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
1431         $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
1432                                 "will not remove\n");
1433         $CPAN::Frontend->mysleep(5);
1434         return;
1435     }
1436     $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
1437         if $CPAN::DEBUG;
1438     File::Path::rmtree($dir);
1439     unlink "$dir.yml"; # may fail
1440     $self->{DU} -= $self->{SIZE}{$dir};
1441     delete $self->{SIZE}{$dir};
1442 }
1443
1444 #-> sub CPAN::CacheMgr::new ;
1445 sub new {
1446     my $class = shift;
1447     my $time = time;
1448     my($debug,$t2);
1449     $debug = "";
1450     my $self = {
1451                 ID => $CPAN::Config->{build_dir},
1452                 MAX => $CPAN::Config->{'build_cache'},
1453                 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
1454                 DU => 0
1455                };
1456     File::Path::mkpath($self->{ID});
1457     my $dh = DirHandle->new($self->{ID});
1458     bless $self, $class;
1459     $self->scan_cache;
1460     $t2 = time;
1461     $debug .= "timing of CacheMgr->new: ".($t2 - $time);
1462     $time = $t2;
1463     CPAN->debug($debug) if $CPAN::DEBUG;
1464     $self;
1465 }
1466
1467 #-> sub CPAN::CacheMgr::scan_cache ;
1468 sub scan_cache {
1469     my $self = shift;
1470     return if $self->{SCAN} eq 'never';
1471     $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
1472         unless $self->{SCAN} eq 'atstart';
1473     $CPAN::Frontend->myprint(
1474                              sprintf("Scanning cache %s for sizes\n",
1475                                      $self->{ID}));
1476     my $e;
1477     my @entries = grep { !/^\.\.?$/ } $self->entries($self->{ID});
1478     my $i = 0;
1479     my $painted = 0;
1480     for $e (@entries) {
1481         # next if $e eq ".." || $e eq ".";
1482         $self->disk_usage($e);
1483         $i++;
1484         while (($painted/76) < ($i/@entries)) {
1485             $CPAN::Frontend->myprint(".");
1486             $painted++;
1487         }
1488         return if $CPAN::Signal;
1489     }
1490     $CPAN::Frontend->myprint("DONE\n");
1491     $self->tidyup;
1492 }
1493
1494 package CPAN::Shell;
1495 use strict;
1496
1497 #-> sub CPAN::Shell::h ;
1498 sub h {
1499     my($class,$about) = @_;
1500     if (defined $about) {
1501         $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1502     } else {
1503         my $filler = " " x (80 - 28 - length($CPAN::VERSION));
1504         $CPAN::Frontend->myprint(qq{
1505 Display Information $filler (ver $CPAN::VERSION)
1506  command  argument          description
1507  a,b,d,m  WORD or /REGEXP/  about authors, bundles, distributions, modules
1508  i        WORD or /REGEXP/  about any of the above
1509  ls       AUTHOR or GLOB    about files in the author's directory
1510     (with WORD being a module, bundle or author name or a distribution
1511     name of the form AUTHOR/DISTRIBUTION)
1512
1513 Download, Test, Make, Install...
1514  get      download                     clean    make clean
1515  make     make (implies get)           look     open subshell in dist directory
1516  test     make test (implies make)     readme   display these README files
1517  install  make install (implies test)  perldoc  display POD documentation
1518
1519 Upgrade
1520  r        WORDs or /REGEXP/ or NONE    report updates for some/matching/all modules
1521  upgrade  WORDs or /REGEXP/ or NONE    upgrade some/matching/all modules
1522
1523 Pragmas
1524  force  CMD    try hard to do command  fforce CMD    try harder
1525  notest CMD    skip testing
1526
1527 Other
1528  h,?           display this menu       ! perl-code   eval a perl command
1529  o conf [opt]  set and query options   q             quit the cpan shell
1530  reload cpan   load CPAN.pm again      reload index  load newer indices
1531  autobundle    Snapshot                recent        latest CPAN uploads});
1532 }
1533 }
1534
1535 *help = \&h;
1536
1537 #-> sub CPAN::Shell::a ;
1538 sub a {
1539   my($self,@arg) = @_;
1540   # authors are always UPPERCASE
1541   for (@arg) {
1542     $_ = uc $_ unless /=/;
1543   }
1544   $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1545 }
1546
1547 #-> sub CPAN::Shell::globls ;
1548 sub globls {
1549     my($self,$s,$pragmas) = @_;
1550     # ls is really very different, but we had it once as an ordinary
1551     # command in the Shell (upto rev. 321) and we could not handle
1552     # force well then
1553     my(@accept,@preexpand);
1554     if ($s =~ /[\*\?\/]/) {
1555         if ($CPAN::META->has_inst("Text::Glob")) {
1556             if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
1557                 my $rau = Text::Glob::glob_to_regex(uc $au);
1558                 CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
1559                       if $CPAN::DEBUG;
1560                 push @preexpand, map { $_->id . "/" . $pathglob }
1561                     CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
1562             } else {
1563                 my $rau = Text::Glob::glob_to_regex(uc $s);
1564                 push @preexpand, map { $_->id }
1565                     CPAN::Shell->expand_by_method('CPAN::Author',
1566                                                   ['id'],
1567                                                   "/$rau/");
1568             }
1569         } else {
1570             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
1571         }
1572     } else {
1573         push @preexpand, uc $s;
1574     }
1575     for (@preexpand) {
1576         unless (/^[A-Z0-9\-]+(\/|$)/i) {
1577             $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
1578             next;
1579         }
1580         push @accept, $_;
1581     }
1582     my $silent = @accept>1;
1583     my $last_alpha = "";
1584     my @results;
1585     for my $a (@accept){
1586         my($author,$pathglob);
1587         if ($a =~ m|(.*?)/(.*)|) {
1588             my $a2 = $1;
1589             $pathglob = $2;
1590             $author = CPAN::Shell->expand_by_method('CPAN::Author',
1591                                                     ['id'],
1592                                                     $a2)
1593                 or $CPAN::Frontend->mydie("No author found for $a2\n");
1594         } else {
1595             $author = CPAN::Shell->expand_by_method('CPAN::Author',
1596                                                     ['id'],
1597                                                     $a)
1598                 or $CPAN::Frontend->mydie("No author found for $a\n");
1599         }
1600         if ($silent) {
1601             my $alpha = substr $author->id, 0, 1;
1602             my $ad;
1603             if ($alpha eq $last_alpha) {
1604                 $ad = "";
1605             } else {
1606                 $ad = "[$alpha]";
1607                 $last_alpha = $alpha;
1608             }
1609             $CPAN::Frontend->myprint($ad);
1610         }
1611         for my $pragma (@$pragmas) {
1612             if ($author->can($pragma)) {
1613                 $author->$pragma();
1614             }
1615         }
1616         push @results, $author->ls($pathglob,$silent); # silent if
1617                                                        # more than one
1618                                                        # author
1619         for my $pragma (@$pragmas) {
1620             my $unpragma = "un$pragma";
1621             if ($author->can($unpragma)) {
1622                 $author->$unpragma();
1623             }
1624         }
1625     }
1626     @results;
1627 }
1628
1629 #-> sub CPAN::Shell::local_bundles ;
1630 sub local_bundles {
1631     my($self,@which) = @_;
1632     my($incdir,$bdir,$dh);
1633     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1634         my @bbase = "Bundle";
1635         while (my $bbase = shift @bbase) {
1636             $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
1637             CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1638             if ($dh = DirHandle->new($bdir)) { # may fail
1639                 my($entry);
1640                 for $entry ($dh->read) {
1641                     next if $entry =~ /^\./;
1642                     next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/;
1643                     if (-d File::Spec->catdir($bdir,$entry)){
1644                         push @bbase, "$bbase\::$entry";
1645                     } else {
1646                         next unless $entry =~ s/\.pm(?!\n)\Z//;
1647                         $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1648                     }
1649                 }
1650             }
1651         }
1652     }
1653 }
1654
1655 #-> sub CPAN::Shell::b ;
1656 sub b {
1657     my($self,@which) = @_;
1658     CPAN->debug("which[@which]") if $CPAN::DEBUG;
1659     $self->local_bundles;
1660     $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1661 }
1662
1663 #-> sub CPAN::Shell::d ;
1664 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1665
1666 #-> sub CPAN::Shell::m ;
1667 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1668     my $self = shift;
1669     $CPAN::Frontend->myprint($self->format_result('Module',@_));
1670 }
1671
1672 #-> sub CPAN::Shell::i ;
1673 sub i {
1674     my($self) = shift;
1675     my(@args) = @_;
1676     @args = '/./' unless @args;
1677     my(@result);
1678     for my $type (qw/Bundle Distribution Module/) {
1679         push @result, $self->expand($type,@args);
1680     }
1681     # Authors are always uppercase.
1682     push @result, $self->expand("Author", map { uc $_ } @args);
1683
1684     my $result = @result == 1 ?
1685         $result[0]->as_string :
1686             @result == 0 ?
1687                 "No objects found of any type for argument @args\n" :
1688                     join("",
1689                          (map {$_->as_glimpse} @result),
1690                          scalar @result, " items found\n",
1691                         );
1692     $CPAN::Frontend->myprint($result);
1693 }
1694
1695 #-> sub CPAN::Shell::o ;
1696
1697 # CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o
1698 # conf' calls through to CPAN::HandleConfig::edit. 'o conf' should
1699 # probably have been called 'set' and 'o debug' maybe 'set debug' or
1700 # 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm
1701 sub o {
1702     my($self,$o_type,@o_what) = @_;
1703     $o_type ||= "";
1704     CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1705     if ($o_type eq 'conf') {
1706         if (!@o_what) { # print all things, "o conf"
1707             my($k,$v);
1708             $CPAN::Frontend->myprint("\$CPAN::Config options from ");
1709             my @from;
1710             if (exists $INC{'CPAN/Config.pm'}) {
1711                 push @from, $INC{'CPAN/Config.pm'};
1712             }
1713             if (exists $INC{'CPAN/MyConfig.pm'}) {
1714                 push @from, $INC{'CPAN/MyConfig.pm'};
1715             }
1716             $CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from);
1717             $CPAN::Frontend->myprint(":\n");
1718             for $k (sort keys %CPAN::HandleConfig::can) {
1719                 $v = $CPAN::HandleConfig::can{$k};
1720                 $CPAN::Frontend->myprint(sprintf "    %-18s [%s]\n", $k, $v);
1721             }
1722             $CPAN::Frontend->myprint("\n");
1723             for $k (sort keys %$CPAN::Config) {
1724                 CPAN::HandleConfig->prettyprint($k);
1725             }
1726             $CPAN::Frontend->myprint("\n");
1727         } else {
1728             if (CPAN::HandleConfig->edit(@o_what)) {
1729             } else {
1730                 $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
1731                                          qq{items\n\n});
1732             }
1733         }
1734     } elsif ($o_type eq 'debug') {
1735         my(%valid);
1736         @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1737         if (@o_what) {
1738             while (@o_what) {
1739                 my($what) = shift @o_what;
1740                 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
1741                     $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
1742                     next;
1743                 }
1744                 if ( exists $CPAN::DEBUG{$what} ) {
1745                     $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1746                 } elsif ($what =~ /^\d/) {
1747                     $CPAN::DEBUG = $what;
1748                 } elsif (lc $what eq 'all') {
1749                     my($max) = 0;
1750                     for (values %CPAN::DEBUG) {
1751                         $max += $_;
1752                     }
1753                     $CPAN::DEBUG = $max;
1754                 } else {
1755                     my($known) = 0;
1756                     for (keys %CPAN::DEBUG) {
1757                         next unless lc($_) eq lc($what);
1758                         $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1759                         $known = 1;
1760                     }
1761                     $CPAN::Frontend->myprint("unknown argument [$what]\n")
1762                         unless $known;
1763                 }
1764             }
1765         } else {
1766           my $raw = "Valid options for debug are ".
1767               join(", ",sort(keys %CPAN::DEBUG), 'all').
1768                   qq{ or a number. Completion works on the options. }.
1769                       qq{Case is ignored.};
1770           require Text::Wrap;
1771           $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1772           $CPAN::Frontend->myprint("\n\n");
1773         }
1774         if ($CPAN::DEBUG) {
1775             $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n");
1776             my($k,$v);
1777             for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1778                 $v = $CPAN::DEBUG{$k};
1779                 $CPAN::Frontend->myprint(sprintf "    %-14s(%s)\n", $k, $v)
1780                     if $v & $CPAN::DEBUG;
1781             }
1782         } else {
1783             $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1784         }
1785     } else {
1786         $CPAN::Frontend->myprint(qq{
1787 Known options:
1788   conf    set or get configuration variables
1789   debug   set or get debugging options
1790 });
1791     }
1792 }
1793
1794 # CPAN::Shell::paintdots_onreload
1795 sub paintdots_onreload {
1796     my($ref) = shift;
1797     sub {
1798         if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
1799             my($subr) = $1;
1800             ++$$ref;
1801             local($|) = 1;
1802             # $CPAN::Frontend->myprint(".($subr)");
1803             $CPAN::Frontend->myprint(".");
1804             if ($subr =~ /\bshell\b/i) {
1805                 # warn "debug[$_[0]]";
1806
1807                 # It would be nice if we could detect that a
1808                 # subroutine has actually changed, but for now we
1809                 # practically always set the GOTOSHELL global
1810
1811                 $CPAN::GOTOSHELL=1;
1812             }
1813             return;
1814         }
1815         warn @_;
1816     };
1817 }
1818
1819 #-> sub CPAN::Shell::hosts ;
1820 sub hosts {
1821     my($self) = @_;
1822     my $fullstats = CPAN::FTP->_ftp_statistics();
1823     my $history = $fullstats->{history} || [];
1824     my %S; # statistics
1825     while (my $last = pop @$history) {
1826         my $attempts = $last->{attempts} or next;
1827         my $start;
1828         if (@$attempts) {
1829             $start = $attempts->[-1]{start};
1830             if ($#$attempts > 0) {
1831                 for my $i (0..$#$attempts-1) {
1832                     my $url = $attempts->[$i]{url} or next;
1833                     $S{no}{$url}++;
1834                 }
1835             }
1836         } else {
1837             $start = $last->{start};
1838         }
1839         next unless $last->{thesiteurl}; # C-C? bad filenames?
1840         $S{start} = $start;
1841         $S{end} ||= $last->{end};
1842         my $dltime = $last->{end} - $start;
1843         my $dlsize = $last->{filesize} || 0;
1844         my $url = $last->{thesiteurl}->text;
1845         my $s = $S{ok}{$url} ||= {};
1846         $s->{n}++;
1847         $s->{dlsize} ||= 0;
1848         $s->{dlsize} += $dlsize/1024;
1849         $s->{dltime} ||= 0;
1850         $s->{dltime} += $dltime;
1851     }
1852     my $res;
1853     for my $url (keys %{$S{ok}}) {
1854         next if $S{ok}{$url}{dltime} == 0; # div by zero
1855         push @{$res->{ok}}, [@{$S{ok}{$url}}{qw(n dlsize dltime)},
1856                              $S{ok}{$url}{dlsize}/$S{ok}{$url}{dltime},
1857                              $url,
1858                             ];
1859     }
1860     for my $url (keys %{$S{no}}) {
1861         push @{$res->{no}}, [$S{no}{$url},
1862                              $url,
1863                             ];
1864     }
1865     my $R = ""; # report
1866     if ($S{start} && $S{end}) {
1867         $R .= sprintf "Log starts: %s\n", $S{start} ? scalar(localtime $S{start}) : "unknown";
1868         $R .= sprintf "Log ends  : %s\n", $S{end}   ? scalar(localtime $S{end})   : "unknown";
1869     }
1870     if ($res->{ok} && @{$res->{ok}}) {
1871         $R .= sprintf "\nSuccessful downloads:
1872    N       kB  secs      kB/s url\n";
1873         my $i = 20;
1874         for (sort { $b->[3] <=> $a->[3] } @{$res->{ok}}) {
1875             $R .= sprintf "%4d %8d %5d %9.1f %s\n", @$_;
1876             last if --$i<=0;
1877         }
1878     }
1879     if ($res->{no} && @{$res->{no}}) {
1880         $R .= sprintf "\nUnsuccessful downloads:\n";
1881         my $i = 20;
1882         for (sort { $b->[0] <=> $a->[0] } @{$res->{no}}) {
1883             $R .= sprintf "%4d %s\n", @$_;
1884             last if --$i<=0;
1885         }
1886     }
1887     $CPAN::Frontend->myprint($R);
1888 }
1889
1890 #-> sub CPAN::Shell::reload ;
1891 sub reload {
1892     my($self,$command,@arg) = @_;
1893     $command ||= "";
1894     $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1895     if ($command =~ /^cpan$/i) {
1896         my $redef = 0;
1897         chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
1898         my $failed;
1899         my @relo = (
1900                     "CPAN.pm",
1901                     "CPAN/Debug.pm",
1902                     "CPAN/FirstTime.pm",
1903                     "CPAN/HandleConfig.pm",
1904                     "CPAN/Kwalify.pm",
1905                     "CPAN/Queue.pm",
1906                     "CPAN/Reporter.pm",
1907                     "CPAN/Tarzip.pm",
1908                     "CPAN/Version.pm",
1909                    );
1910       MFILE: for my $f (@relo) {
1911             next unless exists $INC{$f};
1912             my $p = $f;
1913             $p =~ s/\.pm$//;
1914             $p =~ s|/|::|g;
1915             $CPAN::Frontend->myprint("($p");
1916             local($SIG{__WARN__}) = paintdots_onreload(\$redef);
1917             $self->_reload_this($f) or $failed++;
1918             my $v = eval "$p\::->VERSION";
1919             $CPAN::Frontend->myprint("v$v)");
1920         }
1921         $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1922         if ($failed) {
1923             my $errors = $failed == 1 ? "error" : "errors";
1924             $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ".
1925                                     "this session.\n");
1926         }
1927     } elsif ($command =~ /^index$/i) {
1928       CPAN::Index->force_reload;
1929     } else {
1930       $CPAN::Frontend->myprint(qq{cpan     re-evals the CPAN modules
1931 index    re-reads the index files\n});
1932     }
1933 }
1934
1935 # reload means only load again what we have loaded before
1936 #-> sub CPAN::Shell::_reload_this ;
1937 sub _reload_this {
1938     my($self,$f,$args) = @_;
1939     CPAN->debug("f[$f]") if $CPAN::DEBUG;
1940     return 1 unless $INC{$f}; # we never loaded this, so we do not
1941                               # reload but say OK
1942     my $pwd = CPAN::anycwd();
1943     CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG;
1944     my($file);
1945     for my $inc (@INC) {
1946         $file = File::Spec->catfile($inc,split /\//, $f);
1947         last if -f $file;
1948         $file = "";
1949     }
1950     CPAN->debug("file[$file]") if $CPAN::DEBUG;
1951     my @inc = @INC;
1952     unless ($file && -f $file) {
1953         # this thingie is not in the INC path, maybe CPAN/MyConfig.pm?
1954         $file = $INC{$f};
1955         unless (CPAN->has_inst("File::Basename")) {
1956             @inc = File::Basename::dirname($file);
1957         } else {
1958             # do we ever need this?
1959             @inc = substr($file,0,-length($f)-1); # bring in back to me!
1960         }
1961     }
1962     CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG;
1963     unless (-f $file) {
1964         $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
1965         return;
1966     }
1967     my $mtime = (stat $file)[9];
1968     $reload->{$f} ||= $^T;
1969     my $must_reload = $mtime > $reload->{$f};
1970     $args ||= {};
1971     $must_reload ||= $args->{reloforce};
1972     if ($must_reload) {
1973         my $fh = FileHandle->new($file) or
1974             $CPAN::Frontend->mydie("Could not open $file: $!");
1975         local($/);
1976         local $^W = 1;
1977         my $content = <$fh>;
1978         CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
1979             if $CPAN::DEBUG;
1980         delete $INC{$f};
1981         local @INC = @inc;
1982         eval "require '$f'";
1983         if ($@){
1984             warn $@;
1985             return;
1986         }
1987         $reload->{$f} = time;
1988     } else {
1989         $CPAN::Frontend->myprint("__unchanged__");
1990     }
1991     return 1;
1992 }
1993
1994 #-> sub CPAN::Shell::mkmyconfig ;
1995 sub mkmyconfig {
1996     my($self, $cpanpm, %args) = @_;
1997     require CPAN::FirstTime;
1998     my $home = CPAN::HandleConfig::home;
1999     $cpanpm = $INC{'CPAN/MyConfig.pm'} ||
2000         File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm");
2001     File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm;
2002     CPAN::HandleConfig::require_myconfig_or_config;
2003     $CPAN::Config ||= {};
2004     $CPAN::Config = {
2005         %$CPAN::Config,
2006         build_dir           =>  undef,
2007         cpan_home           =>  undef,
2008         keep_source_where   =>  undef,
2009         histfile            =>  undef,
2010     };
2011     CPAN::FirstTime::init($cpanpm, %args);
2012 }
2013
2014 #-> sub CPAN::Shell::_binary_extensions ;
2015 sub _binary_extensions {
2016     my($self) = shift @_;
2017     my(@result,$module,%seen,%need,$headerdone);
2018     for $module ($self->expand('Module','/./')) {
2019         my $file  = $module->cpan_file;
2020         next if $file eq "N/A";
2021         next if $file =~ /^Contact Author/;
2022         my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
2023         next if $dist->isa_perl;
2024         next unless $module->xs_file;
2025         local($|) = 1;
2026         $CPAN::Frontend->myprint(".");
2027         push @result, $module;
2028     }
2029 #    print join " | ", @result;
2030     $CPAN::Frontend->myprint("\n");
2031     return @result;
2032 }
2033
2034 #-> sub CPAN::Shell::recompile ;
2035 sub recompile {
2036     my($self) = shift @_;
2037     my($module,@module,$cpan_file,%dist);
2038     @module = $self->_binary_extensions();
2039     for $module (@module){  # we force now and compile later, so we
2040                             # don't do it twice
2041         $cpan_file = $module->cpan_file;
2042         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
2043         $pack->force; #
2044         $dist{$cpan_file}++;
2045     }
2046     for $cpan_file (sort keys %dist) {
2047         $CPAN::Frontend->myprint("  CPAN: Recompiling $cpan_file\n\n");
2048         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
2049         $pack->install;
2050         $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
2051                            # stop a package from recompiling,
2052                            # e.g. IO-1.12 when we have perl5.003_10
2053     }
2054 }
2055
2056 #-> sub CPAN::Shell::scripts ;
2057 sub scripts {
2058     my($self, $arg) = @_;
2059     $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");
2060
2061     for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) {
2062         unless ($CPAN::META->has_inst($req)) {
2063             $CPAN::Frontend->mywarn("  $req not available\n");
2064         }
2065     }
2066     my $p = HTML::LinkExtor->new();
2067     my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html";
2068     unless (-f $indexfile) {
2069         $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n");
2070     }
2071     $p->parse_file($indexfile);
2072     my @hrefs;
2073     my $qrarg;
2074     if ($arg =~ s|^/(.+)/$|$1|) {
2075         $qrarg = eval 'qr/$arg/'; # hide construct from 5.004
2076     }
2077     for my $l ($p->links) {
2078         my $tag = shift @$l;
2079         next unless $tag eq "a";
2080         my %att = @$l;
2081         my $href = $att{href};
2082         next unless $href =~ s|^\.\./authors/id/./../||;
2083         if ($arg) {
2084             if ($qrarg) {
2085                 if ($href =~ $qrarg) {
2086                     push @hrefs, $href;
2087                 }
2088             } else {
2089                 if ($href =~ /\Q$arg\E/) {
2090                     push @hrefs, $href;
2091                 }
2092             }
2093         } else {
2094             push @hrefs, $href;
2095         }
2096     }
2097     # now filter for the latest version if there is more than one of a name
2098     my %stems;
2099     for (sort @hrefs) {
2100         my $href = $_;
2101         s/-v?\d.*//;
2102         my $stem = $_;
2103         $stems{$stem} ||= [];
2104         push @{$stems{$stem}}, $href;
2105     }
2106     for (sort keys %stems) {
2107         my $highest;
2108         if (@{$stems{$_}} > 1) {
2109             $highest = List::Util::reduce {
2110                 Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b
2111               } @{$stems{$_}};
2112         } else {
2113             $highest = $stems{$_}[0];
2114         }
2115         $CPAN::Frontend->myprint("$highest\n");
2116     }
2117 }
2118
2119 #-> sub CPAN::Shell::report ;
2120 sub report {
2121     my($self,@args) = @_;
2122     unless ($CPAN::META->has_inst("CPAN::Reporter")) {
2123         $CPAN::Frontend->mydie("CPAN::Reporter not installed; cannot continue");
2124     }
2125     local $CPAN::Config->{test_report} = 1;
2126     $self->force("test",@args); # force is there so that the test be
2127                                 # re-run (as documented)
2128 }
2129
2130 # experimental (compare with _is_tested)
2131 #-> sub CPAN::Shell::install_tested
2132 sub install_tested {
2133     my($self,@some) = @_;
2134     $CPAN::Frontend->mywarn("install_tested() must not be called with arguments.\n"),
2135         return if @some;
2136     CPAN::Index->reload;
2137
2138     for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
2139         my $yaml = "$b.yml";
2140         unless (-f $yaml){
2141             $CPAN::Frontend->mywarn("No YAML file for $b available, skipping\n");
2142             next;
2143         }
2144         my $yaml_content = CPAN::_yaml_loadfile($yaml);
2145         my $id = $yaml_content->[0]{ID};
2146         unless ($id){
2147             $CPAN::Frontend->mywarn("No ID found in '$yaml', skipping\n");
2148             next;
2149         }
2150         my $do = CPAN::Shell->expandany($id);
2151         unless ($do){
2152             $CPAN::Frontend->mywarn("Could not expand ID '$id', skipping\n");
2153             next;
2154         }
2155         unless ($do->{build_dir}) {
2156             $CPAN::Frontend->mywarn("Distro '$id' has no build_dir, skipping\n");
2157             next;
2158         }
2159         unless ($do->{build_dir} eq $b) {
2160             $CPAN::Frontend->mywarn("Distro '$id' has build_dir '$do->{build_dir}' but expected '$b', skipping\n");
2161             next;
2162         }
2163         push @some, $do;
2164     }
2165
2166     $CPAN::Frontend->mywarn("No tested distributions found.\n"),
2167         return unless @some;
2168
2169     @some = grep { $_->{make_test} && ! $_->{make_test}->failed } @some;
2170     $CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"),
2171         return unless @some;
2172
2173     # @some = grep { not $_->uptodate } @some;
2174     # $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"),
2175     #     return unless @some;
2176
2177     CPAN->debug("some[@some]");
2178     for my $d (@some) {
2179         my $id = $d->can("pretty_id") ? $d->pretty_id : $d->id;
2180         $CPAN::Frontend->myprint("install_tested: Running for $id\n");
2181         $CPAN::Frontend->mysleep(1);
2182         $self->install($d);
2183     }
2184 }
2185
2186 #-> sub CPAN::Shell::upgrade ;
2187 sub upgrade {
2188     my($self,@args) = @_;
2189     $self->install($self->r(@args));
2190 }
2191
2192 #-> sub CPAN::Shell::_u_r_common ;
2193 sub _u_r_common {
2194     my($self) = shift @_;
2195     my($what) = shift @_;
2196     CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
2197     Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
2198           $what && $what =~ /^[aru]$/;
2199     my(@args) = @_;
2200     @args = '/./' unless @args;
2201     my(@result,$module,%seen,%need,$headerdone,
2202        $version_undefs,$version_zeroes);
2203     $version_undefs = $version_zeroes = 0;
2204     my $sprintf = "%s%-25s%s %9s %9s  %s\n";
2205     my @expand = $self->expand('Module',@args);
2206     my $expand = scalar @expand;
2207     if (0) { # Looks like noise to me, was very useful for debugging
2208              # for metadata cache
2209         $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
2210     }
2211   MODULE: for $module (@expand) {
2212         my $file  = $module->cpan_file;
2213         next MODULE unless defined $file; # ??
2214         $file =~ s|^./../||;
2215         my($latest) = $module->cpan_version;
2216         my($inst_file) = $module->inst_file;
2217         my($have);
2218         return if $CPAN::Signal;
2219         if ($inst_file){
2220             if ($what eq "a") {
2221                 $have = $module->inst_version;
2222             } elsif ($what eq "r") {
2223                 $have = $module->inst_version;
2224                 local($^W) = 0;
2225                 if ($have eq "undef"){
2226                     $version_undefs++;
2227                 } elsif ($have == 0){
2228                     $version_zeroes++;
2229                 }
2230                 next MODULE unless CPAN::Version->vgt($latest, $have);
2231 # to be pedantic we should probably say:
2232 #    && !($have eq "undef" && $latest ne "undef" && $latest gt "");
2233 # to catch the case where CPAN has a version 0 and we have a version undef
2234             } elsif ($what eq "u") {
2235                 next MODULE;
2236             }
2237         } else {
2238             if ($what eq "a") {
2239                 next MODULE;
2240             } elsif ($what eq "r") {
2241                 next MODULE;
2242             } elsif ($what eq "u") {
2243                 $have = "-";
2244             }
2245         }
2246         return if $CPAN::Signal; # this is sometimes lengthy
2247         $seen{$file} ||= 0;
2248         if ($what eq "a") {
2249             push @result, sprintf "%s %s\n", $module->id, $have;
2250         } elsif ($what eq "r") {
2251             push @result, $module->id;
2252             next MODULE if $seen{$file}++;
2253         } elsif ($what eq "u") {
2254             push @result, $module->id;
2255             next MODULE if $seen{$file}++;
2256             next MODULE if $file =~ /^Contact/;
2257         }
2258         unless ($headerdone++){
2259             $CPAN::Frontend->myprint("\n");
2260             $CPAN::Frontend->myprint(sprintf(
2261                                              $sprintf,
2262                                              "",
2263                                              "Package namespace",
2264                                              "",
2265                                              "installed",
2266                                              "latest",
2267                                              "in CPAN file"
2268                                             ));
2269         }
2270         my $color_on = "";
2271         my $color_off = "";
2272         if (
2273             $COLOR_REGISTERED
2274             &&
2275             $CPAN::META->has_inst("Term::ANSIColor")
2276             &&
2277             $module->description
2278            ) {
2279             $color_on = Term::ANSIColor::color("green");
2280             $color_off = Term::ANSIColor::color("reset");
2281         }
2282         $CPAN::Frontend->myprint(sprintf $sprintf,
2283                                  $color_on,
2284                                  $module->id,
2285                                  $color_off,
2286                                  $have,
2287                                  $latest,
2288                                  $file);
2289         $need{$module->id}++;
2290     }
2291     unless (%need) {
2292         if ($what eq "u") {
2293             $CPAN::Frontend->myprint("No modules found for @args\n");
2294         } elsif ($what eq "r") {
2295             $CPAN::Frontend->myprint("All modules are up to date for @args\n");
2296         }
2297     }
2298     if ($what eq "r") {
2299         if ($version_zeroes) {
2300             my $s_has = $version_zeroes > 1 ? "s have" : " has";
2301             $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
2302                 qq{a version number of 0\n});
2303         }
2304         if ($version_undefs) {
2305             my $s_has = $version_undefs > 1 ? "s have" : " has";
2306             $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
2307                 qq{parseable version number\n});
2308         }
2309     }
2310     @result;
2311 }
2312
2313 #-> sub CPAN::Shell::r ;
2314 sub r {
2315     shift->_u_r_common("r",@_);
2316 }
2317
2318 #-> sub CPAN::Shell::u ;
2319 sub u {
2320     shift->_u_r_common("u",@_);
2321 }
2322
2323 #-> sub CPAN::Shell::failed ;
2324 sub failed {
2325     my($self,$only_id,$silent) = @_;
2326     my @failed;
2327   DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
2328         my $failed = "";
2329       NAY: for my $nosayer ( # order matters!
2330                             "unwrapped",
2331                             "writemakefile",
2332                             "signature_verify",
2333                             "make",
2334                             "make_test",
2335                             "install",
2336                             "make_clean",
2337                            ) {
2338             next unless exists $d->{$nosayer};
2339             next unless defined $d->{$nosayer};
2340             next unless (
2341                          UNIVERSAL::can($d->{$nosayer},"failed") ?
2342                          $d->{$nosayer}->failed :
2343                          $d->{$nosayer} =~ /^NO/
2344                         );
2345             next NAY if $only_id && $only_id != (
2346                                                  UNIVERSAL::can($d->{$nosayer},"commandid")
2347                                                  ?
2348                                                  $d->{$nosayer}->commandid
2349                                                  :
2350                                                  $CPAN::CurrentCommandId
2351                                                 );
2352             $failed = $nosayer;
2353             last;
2354         }
2355         next DIST unless $failed;
2356         my $id = $d->id;
2357         $id =~ s|^./../||;
2358         #$print .= sprintf(
2359         #                  "  %-45s: %s %s\n",
2360         push @failed,
2361             (
2362              UNIVERSAL::can($d->{$failed},"failed") ?
2363              [
2364               $d->{$failed}->commandid,
2365               $id,
2366               $failed,
2367               $d->{$failed}->text,
2368               $d->{$failed}{TIME}||0,
2369              ] :
2370              [
2371               1,
2372               $id,
2373               $failed,
2374               $d->{$failed},
2375               0,
2376              ]
2377             );
2378     }
2379     my $scope;
2380     if ($only_id) {
2381         $scope = "this command";
2382     } elsif ($CPAN::Index::HAVE_REANIMATED) {
2383         $scope = "this or a previous session";
2384         # it might be nice to have a section for previous session and
2385         # a second for this
2386     } else {
2387         $scope = "this session";
2388     }
2389     if (@failed) {
2390         my $print;
2391         my $debug = 0;
2392         if ($debug) {
2393             $print = join "",
2394                 map { sprintf "%5d %-45s: %s %s\n", @$_ }
2395                     sort { $a->[0] <=> $b->[0] } @failed;
2396         } else {
2397             $print = join "",
2398                 map { sprintf " %-45s: %s %s\n", @$_[1..3] }
2399                     sort {
2400                         $a->[0] <=> $b->[0]
2401                             ||
2402                                 $a->[4] <=> $b->[4]
2403                        } @failed;
2404         }
2405         $CPAN::Frontend->myprint("Failed during $scope:\n$print");
2406     } elsif (!$only_id || !$silent) {
2407         $CPAN::Frontend->myprint("Nothing failed in $scope\n");
2408     }
2409 }
2410
2411 # XXX intentionally undocumented because completely bogus, unportable,
2412 # useless, etc.
2413
2414 #-> sub CPAN::Shell::status ;
2415 sub status {
2416     my($self) = @_;
2417     require Devel::Size;
2418     my $ps = FileHandle->new;
2419     open $ps, "/proc/$$/status";
2420     my $vm = 0;
2421     while (<$ps>) {
2422         next unless /VmSize:\s+(\d+)/;
2423         $vm = $1;
2424         last;
2425     }
2426     $CPAN::Frontend->mywarn(sprintf(
2427                                     "%-27s %6d\n%-27s %6d\n",
2428                                     "vm",
2429                                     $vm,
2430                                     "CPAN::META",
2431                                     Devel::Size::total_size($CPAN::META)/1024,
2432                                    ));
2433     for my $k (sort keys %$CPAN::META) {
2434         next unless substr($k,0,4) eq "read";
2435         warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
2436         for my $k2 (sort keys %{$CPAN::META->{$k}}) {
2437             warn sprintf "  %-25s %6d (keys: %6d)\n",
2438                 $k2,
2439                     Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
2440                           scalar keys %{$CPAN::META->{$k}{$k2}};
2441         }
2442     }
2443 }
2444
2445 # experimental (must run after failed or similar [I think])
2446 # intended as a preparation ot install_tested
2447 #-> sub CPAN::Shell::is_tested
2448 sub _is_tested {
2449     my($self) = @_;
2450     for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
2451         my $time;
2452         if ($CPAN::META->{is_tested}{$b}) {
2453             $time = scalar(localtime $CPAN::META->{is_tested}{$b});
2454         } else {
2455             $time = scalar localtime;
2456             $time =~ s/\S/?/g;
2457         }
2458         $CPAN::Frontend->myprint(sprintf "%s %s\n", $time, $b);
2459     }
2460 }
2461
2462 #-> sub CPAN::Shell::autobundle ;
2463 sub autobundle {
2464     my($self) = shift;
2465     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
2466     my(@bundle) = $self->_u_r_common("a",@_);
2467     my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
2468     File::Path::mkpath($todir);
2469     unless (-d $todir) {
2470         $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
2471         return;
2472     }
2473     my($y,$m,$d) =  (localtime)[5,4,3];
2474     $y+=1900;
2475     $m++;
2476     my($c) = 0;
2477     my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
2478     my($to) = File::Spec->catfile($todir,"$me.pm");
2479     while (-f $to) {
2480         $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
2481         $to = File::Spec->catfile($todir,"$me.pm");
2482     }
2483     my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
2484     $fh->print(
2485                "package Bundle::$me;\n\n",
2486                "\$VERSION = '0.01';\n\n",
2487                "1;\n\n",
2488                "__END__\n\n",
2489                "=head1 NAME\n\n",
2490                "Bundle::$me - Snapshot of installation on ",
2491                $Config::Config{'myhostname'},
2492                " on ",
2493                scalar(localtime),
2494                "\n\n=head1 SYNOPSIS\n\n",
2495                "perl -MCPAN -e 'install Bundle::$me'\n\n",
2496                "=head1 CONTENTS\n\n",
2497                join("\n", @bundle),
2498                "\n\n=head1 CONFIGURATION\n\n",
2499                Config->myconfig,
2500                "\n\n=head1 AUTHOR\n\n",
2501                "This Bundle has been generated automatically ",
2502                "by the autobundle routine in CPAN.pm.\n",
2503               );
2504     $fh->close;
2505     $CPAN::Frontend->myprint("\nWrote bundle file
2506     $to\n\n");
2507 }
2508
2509 #-> sub CPAN::Shell::expandany ;
2510 sub expandany {
2511     my($self,$s) = @_;
2512     CPAN->debug("s[$s]") if $CPAN::DEBUG;
2513     if ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory
2514         $s = CPAN::Distribution->normalize($s);
2515         return $CPAN::META->instance('CPAN::Distribution',$s);
2516         # Distributions spring into existence, not expand
2517     } elsif ($s =~ m|^Bundle::|) {
2518         $self->local_bundles; # scanning so late for bundles seems
2519                               # both attractive and crumpy: always
2520                               # current state but easy to forget
2521                               # somewhere
2522         return $self->expand('Bundle',$s);
2523     } else {
2524         return $self->expand('Module',$s)
2525             if $CPAN::META->exists('CPAN::Module',$s);
2526     }
2527     return;
2528 }
2529
2530 #-> sub CPAN::Shell::expand ;
2531 sub expand {
2532     my $self = shift;
2533     my($type,@args) = @_;
2534     CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
2535     my $class = "CPAN::$type";
2536     my $methods = ['id'];
2537     for my $meth (qw(name)) {
2538         next unless $class->can($meth);
2539         push @$methods, $meth;
2540     }
2541     $self->expand_by_method($class,$methods,@args);
2542 }
2543
2544 #-> sub CPAN::Shell::expand_by_method ;
2545 sub expand_by_method {
2546     my $self = shift;
2547     my($class,$methods,@args) = @_;
2548     my($arg,@m);
2549     for $arg (@args) {
2550         my($regex,$command);
2551         if ($arg =~ m|^/(.*)/$|) {
2552             $regex = $1;
2553         } elsif ($arg =~ m/=/) {
2554             $command = 1;
2555         }
2556         my $obj;
2557         CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
2558                     $class,
2559                     defined $regex ? $regex : "UNDEFINED",
2560                     defined $command ? $command : "UNDEFINED",
2561                    ) if $CPAN::DEBUG;
2562         if (defined $regex) {
2563             if (CPAN::_sqlite_running) {
2564                 $CPAN::SQLite->search($class, $regex);
2565             }
2566             for $obj (
2567                       $CPAN::META->all_objects($class)
2568                      ) {
2569                 unless ($obj && UNIVERSAL::can($obj,"id") && $obj->id){
2570                     # BUG, we got an empty object somewhere
2571                     require Data::Dumper;
2572                     CPAN->debug(sprintf(
2573                                         "Bug in CPAN: Empty id on obj[%s][%s]",
2574                                         $obj,
2575                                         Data::Dumper::Dumper($obj)
2576                                        )) if $CPAN::DEBUG;
2577                     next;
2578                 }
2579                 for my $method (@$methods) {
2580                     my $match = eval {$obj->$method() =~ /$regex/i};
2581                     if ($@) {
2582                         my($err) = $@ =~ /^(.+) at .+? line \d+\.$/;
2583                         $err ||= $@; # if we were too restrictive above
2584                         $CPAN::Frontend->mydie("$err\n");
2585                     } elsif ($match) {
2586                         push @m, $obj;
2587                         last;
2588                     }
2589                 }
2590             }
2591         } elsif ($command) {
2592             die "equal sign in command disabled (immature interface), ".
2593                 "you can set
2594  ! \$CPAN::Shell::ADVANCED_QUERY=1
2595 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
2596 that may go away anytime.\n"
2597                     unless $ADVANCED_QUERY;
2598             my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
2599             my($matchcrit) = $criterion =~ m/^~(.+)/;
2600             for my $self (
2601                           sort
2602                           {$a->id cmp $b->id}
2603                           $CPAN::META->all_objects($class)
2604                          ) {
2605                 my $lhs = $self->$method() or next; # () for 5.00503
2606                 if ($matchcrit) {
2607                     push @m, $self if $lhs =~ m/$matchcrit/;
2608                 } else {
2609                     push @m, $self if $lhs eq $criterion;
2610                 }
2611             }
2612         } else {
2613             my($xarg) = $arg;
2614             if ( $class eq 'CPAN::Bundle' ) {
2615                 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
2616             } elsif ($class eq "CPAN::Distribution") {
2617                 $xarg = CPAN::Distribution->normalize($arg);
2618             } else {
2619                 $xarg =~ s/:+/::/g;
2620             }
2621             if ($CPAN::META->exists($class,$xarg)) {
2622                 $obj = $CPAN::META->instance($class,$xarg);
2623             } elsif ($CPAN::META->exists($class,$arg)) {
2624                 $obj = $CPAN::META->instance($class,$arg);
2625             } else {
2626                 next;
2627             }
2628             push @m, $obj;
2629         }
2630     }
2631     @m = sort {$a->id cmp $b->id} @m;
2632     if ( $CPAN::DEBUG ) {
2633         my $wantarray = wantarray;
2634         my $join_m = join ",", map {$_->id} @m;
2635         $self->debug("wantarray[$wantarray]join_m[$join_m]");
2636     }
2637     return wantarray ? @m : $m[0];
2638 }
2639
2640 #-> sub CPAN::Shell::format_result ;
2641 sub format_result {
2642     my($self) = shift;
2643     my($type,@args) = @_;
2644     @args = '/./' unless @args;
2645     my(@result) = $self->expand($type,@args);
2646     my $result = @result == 1 ?
2647         $result[0]->as_string :
2648             @result == 0 ?
2649                 "No objects of type $type found for argument @args\n" :
2650                     join("",
2651                          (map {$_->as_glimpse} @result),
2652                          scalar @result, " items found\n",
2653                         );
2654     $result;
2655 }
2656
2657 #-> sub CPAN::Shell::report_fh ;
2658 {
2659     my $installation_report_fh;
2660     my $previously_noticed = 0;
2661
2662     sub report_fh {
2663         return $installation_report_fh if $installation_report_fh;
2664         if ($CPAN::META->has_inst("File::Temp")) {
2665             $installation_report_fh
2666                 = File::Temp->new(
2667                                   template => 'cpan_install_XXXX',
2668                                   suffix   => '.txt',
2669                                   unlink   => 0,
2670                                  );
2671         }
2672         unless ( $installation_report_fh ) {
2673             warn("Couldn't open installation report file; " .
2674                  "no report file will be generated."
2675                 ) unless $previously_noticed++;
2676         }
2677     }
2678 }
2679
2680
2681 # The only reason for this method is currently to have a reliable
2682 # debugging utility that reveals which output is going through which
2683 # channel. No, I don't like the colors ;-)
2684
2685 # to turn colordebugging on, write
2686 # cpan> o conf colorize_output 1
2687
2688 #-> sub CPAN::Shell::print_ornamented ;
2689 {
2690     my $print_ornamented_have_warned = 0;
2691     sub colorize_output {
2692         my $colorize_output = $CPAN::Config->{colorize_output};
2693         if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
2694             unless ($print_ornamented_have_warned++) {
2695                 # no myprint/mywarn within myprint/mywarn!
2696                 warn "Colorize_output is set to true but Term::ANSIColor is not
2697 installed. To activate colorized output, please install Term::ANSIColor.\n\n";
2698             }
2699             $colorize_output = 0;
2700         }
2701         return $colorize_output;
2702     }
2703 }
2704
2705
2706 #-> sub CPAN::Shell::print_ornamented ;
2707 sub print_ornamented {
2708     my($self,$what,$ornament) = @_;
2709     return unless defined $what;
2710
2711     local $| = 1; # Flush immediately
2712     if ( $CPAN::Be_Silent ) {
2713         print {report_fh()} $what;
2714         return;
2715     }
2716     my $swhat = "$what"; # stringify if it is an object
2717     if ($CPAN::Config->{term_is_latin}){
2718         # courtesy jhi:
2719         $swhat
2720             =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
2721     }
2722     if ($self->colorize_output) {
2723         if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
2724             # if you want to have this configurable, please file a bugreport
2725             $ornament = $CPAN::Config->{colorize_debug} || "black on_cyan";
2726         }
2727         my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
2728         if ($@) {
2729             print "Term::ANSIColor rejects color[$ornament]: $@\n
2730 Please choose a different color (Hint: try 'o conf init color.*')\n";
2731         }
2732         print $color_on,
2733             $swhat,
2734                 Term::ANSIColor::color("reset");
2735     } else {
2736         print $swhat;
2737     }
2738 }
2739
2740 #-> sub CPAN::Shell::myprint ;
2741
2742 # where is myprint/mywarn/Frontend/etc. documented? We need guidelines
2743 # where to use what! I think, we send everything to STDOUT and use
2744 # print for normal/good news and warn for news that need more
2745 # attention. Yes, this is our working contract for now.
2746 sub myprint {
2747     my($self,$what) = @_;
2748
2749     $self->print_ornamented($what, $CPAN::Config->{colorize_print}||'bold blue on_white');
2750 }
2751
2752 #-> sub CPAN::Shell::myexit ;
2753 sub myexit {
2754     my($self,$what) = @_;
2755     $self->myprint($what);
2756     exit;
2757 }
2758
2759 #-> sub CPAN::Shell::mywarn ;
2760 sub mywarn {
2761     my($self,$what) = @_;
2762     $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
2763 }
2764
2765 # only to be used for shell commands
2766 #-> sub CPAN::Shell::mydie ;
2767 sub mydie {
2768     my($self,$what) = @_;
2769     $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
2770
2771     # If it is the shell, we want that the following die to be silent,
2772     # but if it is not the shell, we would need a 'die $what'. We need
2773     # to take care that only shell commands use mydie. Is this
2774     # possible?
2775
2776     die "\n";
2777 }
2778
2779 # sub CPAN::Shell::colorable_makemaker_prompt ;
2780 sub colorable_makemaker_prompt {
2781     my($foo,$bar) = @_;
2782     if (CPAN::Shell->colorize_output) {
2783         my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
2784         my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
2785         print $color_on;
2786     }
2787     my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
2788     if (CPAN::Shell->colorize_output) {
2789         print Term::ANSIColor::color('reset');
2790     }
2791     return $ans;
2792 }
2793
2794 # use this only for unrecoverable errors!
2795 #-> sub CPAN::Shell::unrecoverable_error ;
2796 sub unrecoverable_error {
2797     my($self,$what) = @_;
2798     my @lines = split /\n/, $what;
2799     my $longest = 0;
2800     for my $l (@lines) {
2801         $longest = length $l if length $l > $longest;
2802     }
2803     $longest = 62 if $longest > 62;
2804     for my $l (@lines) {
2805         if ($l =~ /^\s*$/){
2806             $l = "\n";
2807             next;
2808         }
2809         $l = "==> $l";
2810         if (length $l < 66) {
2811             $l = pack "A66 A*", $l, "<==";
2812         }
2813         $l .= "\n";
2814     }
2815     unshift @lines, "\n";
2816     $self->mydie(join "", @lines);
2817 }
2818
2819 #-> sub CPAN::Shell::mysleep ;
2820 sub mysleep {
2821     my($self, $sleep) = @_;
2822     sleep $sleep;
2823 }
2824
2825 #-> sub CPAN::Shell::setup_output ;
2826 sub setup_output {
2827     return if -t STDOUT;
2828     my $odef = select STDERR;
2829     $| = 1;
2830     select STDOUT;
2831     $| = 1;
2832     select $odef;
2833 }
2834
2835 #-> sub CPAN::Shell::rematein ;
2836 # RE-adme||MA-ke||TE-st||IN-stall : nearly everything runs through here
2837 sub rematein {
2838     my $self = shift;
2839     my($meth,@some) = @_;
2840     my @pragma;
2841     while($meth =~ /^(ff?orce|notest)$/) {
2842         push @pragma, $meth;
2843         $meth = shift @some or
2844             $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
2845                                    "cannot continue");
2846     }
2847     setup_output();
2848     CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
2849
2850     # Here is the place to set "test_count" on all involved parties to
2851     # 0. We then can pass this counter on to the involved
2852     # distributions and those can refuse to test if test_count > X. In
2853     # the first stab at it we could use a 1 for "X".
2854
2855     # But when do I reset the distributions to start with 0 again?
2856     # Jost suggested to have a random or cycling interaction ID that
2857     # we pass through. But the ID is something that is just left lying
2858     # around in addition to the counter, so I'd prefer to set the
2859     # counter to 0 now, and repeat at the end of the loop. But what
2860     # about dependencies? They appear later and are not reset, they
2861     # enter the queue but not its copy. How do they get a sensible
2862     # test_count?
2863
2864     # construct the queue
2865     my($s,@s,@qcopy);
2866   STHING: foreach $s (@some) {
2867         my $obj;
2868         if (ref $s) {
2869             CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
2870             $obj = $s;
2871         } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
2872         } elsif ($s =~ m|^/|) { # looks like a regexp
2873             if (substr($s,-1,1) eq ".") {
2874                 $obj = CPAN::Shell->expandany($s);
2875             } else {
2876                 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
2877                                         "not supported.\nRejecting argument '$s'\n");
2878                 $CPAN::Frontend->mysleep(2);
2879                 next;
2880             }
2881         } elsif ($meth eq "ls") {
2882             $self->globls($s,\@pragma);
2883             next STHING;
2884         } else {
2885             CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
2886             $obj = CPAN::Shell->expandany($s);
2887         }
2888         if (0) {
2889         } elsif (ref $obj) {
2890             $obj->color_cmd_tmps(0,1);
2891             CPAN::Queue->new(qmod => $obj->id, reqtype => "c");
2892             push @qcopy, $obj;
2893         } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
2894             $obj = $CPAN::META->instance('CPAN::Author',uc($s));
2895             if ($meth =~ /^(dump|ls)$/) {
2896                 $obj->$meth();
2897             } else {
2898                 $CPAN::Frontend->mywarn(
2899                                         join "",
2900                                         "Don't be silly, you can't $meth ",
2901                                         $obj->fullname,
2902                                         " ;-)\n"
2903                                        );
2904                 $CPAN::Frontend->mysleep(2);
2905             }
2906         } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
2907             CPAN::InfoObj->dump($s);
2908         } else {
2909             $CPAN::Frontend
2910                 ->mywarn(qq{Warning: Cannot $meth $s, }.
2911                           qq{don't know what it is.
2912 Try the command
2913
2914     i /$s/
2915
2916 to find objects with matching identifiers.
2917 });
2918             $CPAN::Frontend->mysleep(2);
2919         }
2920     }
2921
2922     # queuerunner (please be warned: when I started to change the
2923     # queue to hold objects instead of names, I made one or two
2924     # mistakes and never found which. I reverted back instead)
2925     while (my $q = CPAN::Queue->first) {
2926         my $obj;
2927         my $s = $q->as_string;
2928         my $reqtype = $q->reqtype || "";
2929         $obj = CPAN::Shell->expandany($s);
2930         $obj->{reqtype} ||= "";
2931         {
2932             # force debugging because CPAN::SQLite somehow delivers us
2933             # an empty object;
2934
2935             # local $CPAN::DEBUG = 1024; # Shell; probably fixed now
2936
2937             CPAN->debug("s[$s]obj-reqtype[$obj->{reqtype}]".
2938                         "q-reqtype[$reqtype]") if $CPAN::DEBUG;
2939         }
2940         if ($obj->{reqtype}) {
2941             if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
2942                 $obj->{reqtype} = $reqtype;
2943                 if (
2944                     exists $obj->{install}
2945                     &&
2946                     (
2947                      UNIVERSAL::can($obj->{install},"failed") ?
2948                      $obj->{install}->failed :
2949                      $obj->{install} =~ /^NO/
2950                     )
2951                    ) {
2952                     delete $obj->{install};
2953                     $CPAN::Frontend->mywarn
2954                         ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
2955                 }
2956             }
2957         } else {
2958             $obj->{reqtype} = $reqtype;
2959         }
2960
2961         for my $pragma (@pragma) {
2962             if ($pragma
2963                 &&
2964                 $obj->can($pragma)){
2965                 $obj->$pragma($meth);
2966             }
2967         }
2968         if (UNIVERSAL::can($obj, 'called_for')) {
2969             $obj->called_for($s);
2970         }
2971         CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
2972                     qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
2973
2974         push @qcopy, $obj;
2975         if (! UNIVERSAL::can($obj,$meth)) {
2976             # Must never happen
2977             my $serialized = "";
2978             if (0) {
2979             } elsif ($CPAN::META->has_inst("YAML::Syck")) {
2980                 $serialized = YAML::Syck::Dump($obj);
2981             } elsif ($CPAN::META->has_inst("YAML")) {
2982                 $serialized = YAML::Dump($obj);
2983             } elsif ($CPAN::META->has_inst("Data::Dumper")) {
2984                 $serialized = Data::Dumper::Dumper($obj);
2985             } else {
2986                 require overload;
2987                 $serialized = overload::StrVal($obj);
2988             }
2989             $CPAN::Frontend->mydie("Panic: obj[$serialized] cannot meth[$meth]");
2990         } elsif ($obj->$meth()){
2991             CPAN::Queue->delete($s);
2992         } else {
2993             CPAN->debug("failed");
2994         }
2995
2996         $obj->undelay;
2997         for my $pragma (@pragma) {
2998             my $unpragma = "un$pragma";
2999             if ($obj->can($unpragma)) {
3000                 $obj->$unpragma();
3001             }
3002         }
3003         CPAN::Queue->delete_first($s);
3004     }
3005     for my $obj (@qcopy) {
3006         $obj->color_cmd_tmps(0,0);
3007     }
3008 }
3009
3010 #-> sub CPAN::Shell::recent ;
3011 sub recent {
3012   my($self) = @_;
3013
3014   CPAN::Distribution::_display_url( $self, $CPAN::Defaultrecent );
3015   return;
3016 }
3017
3018 {
3019     # set up the dispatching methods
3020     no strict "refs";
3021     for my $command (qw(
3022                         clean
3023                         cvs_import
3024                         dump
3025                         force
3026                         fforce
3027                         get
3028                         install
3029                         look
3030                         ls
3031                         make
3032                         notest
3033                         perldoc
3034                         readme
3035                         test
3036                        )) {
3037         *$command = sub { shift->rematein($command, @_); };
3038     }
3039 }
3040
3041 package CPAN::LWP::UserAgent;
3042 use strict;
3043
3044 sub config {
3045     return if $SETUPDONE;
3046     if ($CPAN::META->has_usable('LWP::UserAgent')) {
3047         require LWP::UserAgent;
3048         @ISA = qw(Exporter LWP::UserAgent);
3049         $SETUPDONE++;
3050     } else {
3051         $CPAN::Frontend->mywarn("  LWP::UserAgent not available\n");
3052     }
3053 }
3054
3055 sub get_basic_credentials {
3056     my($self, $realm, $uri, $proxy) = @_;
3057     if ($USER && $PASSWD) {
3058         return ($USER, $PASSWD);
3059     }
3060     if ( $proxy ) {
3061         ($USER,$PASSWD) = $self->get_proxy_credentials();
3062     } else {
3063         ($USER,$PASSWD) = $self->get_non_proxy_credentials();
3064     }
3065     return($USER,$PASSWD);
3066 }
3067
3068 sub get_proxy_credentials {
3069     my $self = shift;
3070     my ($user, $password);
3071     if ( defined $CPAN::Config->{proxy_user} &&
3072          defined $CPAN::Config->{proxy_pass}) {
3073         $user = $CPAN::Config->{proxy_user};
3074         $password = $CPAN::Config->{proxy_pass};
3075         return ($user, $password);
3076     }
3077     my $username_prompt = "\nProxy authentication needed!
3078  (Note: to permanently configure username and password run
3079    o conf proxy_user your_username
3080    o conf proxy_pass your_password
3081      )\nUsername:";
3082     ($user, $password) =
3083         _get_username_and_password_from_user($username_prompt);
3084     return ($user,$password);
3085 }
3086
3087 sub get_non_proxy_credentials {
3088     my $self = shift;
3089     my ($user,$password);
3090     if ( defined $CPAN::Config->{username} &&
3091          defined $CPAN::Config->{password}) {
3092         $user = $CPAN::Config->{username};
3093         $password = $CPAN::Config->{password};
3094         return ($user, $password);
3095     }
3096     my $username_prompt = "\nAuthentication needed!
3097      (Note: to permanently configure username and password run
3098        o conf username your_username
3099        o conf password your_password
3100      )\nUsername:";
3101
3102     ($user, $password) =
3103         _get_username_and_password_from_user($username_prompt);
3104     return ($user,$password);
3105 }
3106
3107 sub _get_username_and_password_from_user {
3108     my $username_message = shift;
3109     my ($username,$password);
3110
3111     ExtUtils::MakeMaker->import(qw(prompt));
3112     $username = prompt($username_message);
3113         if ($CPAN::META->has_inst("Term::ReadKey")) {
3114             Term::ReadKey::ReadMode("noecho");
3115         }
3116     else {
3117         $CPAN::Frontend->mywarn(
3118             "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"
3119         );
3120     }
3121     $password = prompt("Password:");
3122
3123         if ($CPAN::META->has_inst("Term::ReadKey")) {
3124             Term::ReadKey::ReadMode("restore");
3125         }
3126         $CPAN::Frontend->myprint("\n\n");
3127     return ($username,$password);
3128 }
3129
3130 # mirror(): Its purpose is to deal with proxy authentication. When we
3131 # call SUPER::mirror, we relly call the mirror method in
3132 # LWP::UserAgent. LWP::UserAgent will then call
3133 # $self->get_basic_credentials or some equivalent and this will be
3134 # $self->dispatched to our own get_basic_credentials method.
3135
3136 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3137
3138 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3139 # although we have gone through our get_basic_credentials, the proxy
3140 # server refuses to connect. This could be a case where the username or
3141 # password has changed in the meantime, so I'm trying once again without
3142 # $USER and $PASSWD to give the get_basic_credentials routine another
3143 # chance to set $USER and $PASSWD.
3144
3145 # mirror(): Its purpose is to deal with proxy authentication. When we
3146 # call SUPER::mirror, we relly call the mirror method in
3147 # LWP::UserAgent. LWP::UserAgent will then call
3148 # $self->get_basic_credentials or some equivalent and this will be
3149 # $self->dispatched to our own get_basic_credentials method.
3150
3151 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3152
3153 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3154 # although we have gone through our get_basic_credentials, the proxy
3155 # server refuses to connect. This could be a case where the username or
3156 # password has changed in the meantime, so I'm trying once again without
3157 # $USER and $PASSWD to give the get_basic_credentials routine another
3158 # chance to set $USER and $PASSWD.
3159
3160 sub mirror {
3161     my($self,$url,$aslocal) = @_;
3162     my $result = $self->SUPER::mirror($url,$aslocal);
3163     if ($result->code == 407) {
3164         undef $USER;
3165         undef $PASSWD;
3166         $result = $self->SUPER::mirror($url,$aslocal);
3167     }
3168     $result;
3169 }
3170
3171 package CPAN::FTP;
3172 use strict;
3173
3174 #-> sub CPAN::FTP::ftp_statistics
3175 # if they want to rewrite, they need to pass in a filehandle
3176 sub _ftp_statistics {
3177     my($self,$fh) = @_;
3178     my $locktype = $fh ? LOCK_EX : LOCK_SH;
3179     $fh ||= FileHandle->new;
3180     my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3181     open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!");
3182     my $sleep = 1;
3183     my $waitstart;
3184     while (!flock $fh, $locktype|LOCK_NB) {
3185         $waitstart ||= localtime();
3186         if ($sleep>3) {
3187             $CPAN::Frontend->mywarn("Waiting for a read lock on '$file' (since $waitstart)\n");
3188         }
3189         $CPAN::Frontend->mysleep($sleep);
3190         if ($sleep <= 3) {
3191             $sleep+=0.33;
3192         } elsif ($sleep <=6) {
3193             $sleep+=0.11;
3194         }
3195     }
3196     my $stats = eval { CPAN->_yaml_loadfile($file); };
3197     if ($@) {
3198         if (ref $@) {
3199             if (ref $@ eq "CPAN::Exception::yaml_not_installed") {
3200                 $CPAN::Frontend->myprint("Warning (usually harmless): $@");
3201                 return;
3202             } elsif (ref $@ eq "CPAN::Exception::yaml_process_error") {
3203                 $CPAN::Frontend->mydie($@);
3204             }
3205         } else {
3206             $CPAN::Frontend->mydie($@);
3207         }
3208     }
3209     return $stats->[0];
3210 }
3211
3212 #-> sub CPAN::FTP::_mytime
3213 sub _mytime () {
3214     if (CPAN->has_inst("Time::HiRes")) {
3215         return Time::HiRes::time();
3216     } else {
3217         return time;
3218     }
3219 }
3220
3221 #-> sub CPAN::FTP::_new_stats
3222 sub _new_stats {
3223     my($self,$file) = @_;
3224     my $ret = {
3225                file => $file,
3226                attempts => [],
3227                start => _mytime,
3228               };
3229     $ret;
3230 }
3231
3232 #-> sub CPAN::FTP::_add_to_statistics
3233 sub _add_to_statistics {
3234     my($self,$stats) = @_;
3235     my $yaml_module = CPAN::_yaml_module;
3236     if ($CPAN::META->has_inst($yaml_module)) {
3237         $stats->{thesiteurl} = $ThesiteURL;
3238         if (CPAN->has_inst("Time::HiRes")) {
3239             $stats->{end} = Time::HiRes::time();
3240         } else {
3241             $stats->{end} = time;
3242         }
3243         my $fh = FileHandle->new;
3244         my $time = time;
3245         my $sdebug = 0;
3246         my @debug;
3247         @debug = $time if $sdebug;
3248         my $fullstats = $self->_ftp_statistics($fh);
3249         close $fh;
3250         $fullstats->{history} ||= [];
3251         push @debug, scalar @{$fullstats->{history}} if $sdebug;
3252         push @debug, time if $sdebug;
3253         push @{$fullstats->{history}}, $stats;
3254         # arbitrary hardcoded constants until somebody demands to have
3255         # them settable
3256         while (
3257                @{$fullstats->{history}} > 9999
3258                || $time - $fullstats->{history}[0]{start} > 30*86400  # one month
3259               ) {
3260             shift @{$fullstats->{history}}
3261         }
3262         push @debug, scalar @{$fullstats->{history}} if $sdebug;
3263         push @debug, time if $sdebug;
3264         push @debug, scalar localtime($fullstats->{history}[0]{start}) if $sdebug;
3265         # need no eval because if this fails, it is serious
3266         my $sfile = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3267         CPAN->_yaml_dumpfile("$sfile.$$",$fullstats);
3268         if ( $sdebug||$CPAN::DEBUG ) {
3269             local $CPAN::DEBUG = 512; # FTP
3270             push @debug, time;
3271             CPAN->debug(sprintf("DEBUG history: before_read[%d]before[%d]at[%d]".
3272                                 "after[%d]at[%d]oldest[%s]dumped backat[%d]",
3273                                 @debug,
3274                                ));
3275         }
3276         # Win32 cannot rename a file to an existing filename
3277         unlink($sfile) if ($^O eq 'MSWin32');
3278         rename "$sfile.$$", $sfile
3279             or $CPAN::Frontend->mydie("Could not rename '$sfile.$$' to '$sfile': $!\n");
3280     }
3281 }
3282
3283 # if file is CHECKSUMS, suggest the place where we got the file to be
3284 # checked from, maybe only for young files?
3285 #-> sub CPAN::FTP::_recommend_url_for
3286 sub _recommend_url_for {
3287     my($self, $file) = @_;
3288     my $urllist = $self->_get_urllist;
3289     if ($file =~ s|/CHECKSUMS(.gz)?$||) {
3290         my $fullstats = $self->_ftp_statistics();
3291         my $history = $fullstats->{history} || [];
3292         while (my $last = pop @$history) {
3293             last if $last->{end} - time > 3600; # only young results are interesting
3294             next unless $last->{file}; # dirname of nothing dies!
3295             next unless $file eq File::Basename::dirname($last->{file});
3296             return $last->{thesiteurl};
3297         }
3298     }
3299     if ($CPAN::Config->{randomize_urllist}
3300         &&
3301         rand(1) < $CPAN::Config->{randomize_urllist}
3302        ) {
3303         $urllist->[int rand scalar @$urllist];
3304     } else {
3305         return ();
3306     }
3307 }
3308
3309 #-> sub CPAN::FTP::_get_urllist
3310 sub _get_urllist {
3311     my($self) = @_;
3312     $CPAN::Config->{urllist} ||= [];
3313     unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
3314         $CPAN::Frontend->mywarn("Malformed urllist; ignoring.  Configuration file corrupt?\n");
3315         $CPAN::Config->{urllist} = [];
3316     }
3317     my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}};
3318     for my $u (@urllist) {
3319         CPAN->debug("u[$u]") if $CPAN::DEBUG;
3320         if (UNIVERSAL::can($u,"text")) {
3321             $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
3322         } else {
3323             $u .= "/" unless substr($u,-1) eq "/";
3324             $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
3325         }
3326     }
3327     \@urllist;
3328 }
3329
3330 #-> sub CPAN::FTP::ftp_get ;
3331 sub ftp_get {
3332     my($class,$host,$dir,$file,$target) = @_;
3333     $class->debug(
3334                   qq[Going to fetch file [$file] from dir [$dir]
3335         on host [$host] as local [$target]\n]
3336                  ) if $CPAN::DEBUG;
3337     my $ftp = Net::FTP->new($host);
3338     unless ($ftp) {
3339         $CPAN::Frontend->mywarn("  Could not connect to host '$host' with Net::FTP\n");
3340         return;
3341     }
3342     return 0 unless defined $ftp;
3343     $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
3344     $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
3345     unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
3346         my $msg = $ftp->message;
3347         $CPAN::Frontend->mywarn("  Couldn't login on $host: $msg");
3348         return;
3349     }
3350     unless ( $ftp->cwd($dir) ){
3351         my $msg = $ftp->message;
3352         $CPAN::Frontend->mywarn("  Couldn't cwd $dir: $msg");
3353         return;
3354     }
3355     $ftp->binary;
3356     $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
3357     unless ( $ftp->get($file,$target) ){
3358         my $msg = $ftp->message;
3359         $CPAN::Frontend->mywarn("  Couldn't fetch $file from $host: $msg");
3360         return;
3361     }
3362     $ftp->quit; # it's ok if this fails
3363     return 1;
3364 }
3365
3366 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
3367
3368  # > *** /install/perl/live/lib/CPAN.pm-        Wed Sep 24 13:08:48 1997
3369  # > --- /tmp/cp        Wed Sep 24 13:26:40 1997
3370  # > ***************
3371  # > *** 1562,1567 ****
3372  # > --- 1562,1580 ----
3373  # >       return 1 if substr($url,0,4) eq "file";
3374  # >       return 1 unless $url =~ m|://([^/]+)|;
3375  # >       my $host = $1;
3376  # > +     my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
3377  # > +     if ($proxy) {
3378  # > +         $proxy =~ m|://([^/:]+)|;
3379  # > +         $proxy = $1;
3380  # > +         my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
3381  # > +         if ($noproxy) {
3382  # > +             if ($host !~ /$noproxy$/) {
3383  # > +                 $host = $proxy;
3384  # > +             }
3385  # > +         } else {
3386  # > +             $host = $proxy;
3387  # > +         }
3388  # > +     }
3389  # >       require Net::Ping;
3390  # >       return 1 unless $Net::Ping::VERSION >= 2;
3391  # >       my $p;
3392
3393
3394 #-> sub CPAN::FTP::localize ;
3395 sub localize {
3396     my($self,$file,$aslocal,$force) = @_;
3397     $force ||= 0;
3398     Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
3399         unless defined $aslocal;
3400     $self->debug("file[$file] aslocal[$aslocal] force[$force]")
3401         if $CPAN::DEBUG;
3402
3403     if ($^O eq 'MacOS') {
3404         # Comment by AK on 2000-09-03: Uniq short filenames would be
3405         # available in CHECKSUMS file
3406         my($name, $path) = File::Basename::fileparse($aslocal, '');
3407         if (length($name) > 31) {
3408             $name =~ s/(
3409                         \.(
3410                            readme(\.(gz|Z))? |
3411                            (tar\.)?(gz|Z) |
3412                            tgz |
3413                            zip |
3414                            pm\.(gz|Z)
3415                           )
3416                        )$//x;
3417             my $suf = $1;
3418             my $size = 31 - length($suf);
3419             while (length($name) > $size) {
3420                 chop $name;
3421             }
3422             $name .= $suf;
3423             $aslocal = File::Spec->catfile($path, $name);
3424         }
3425     }
3426
3427     if (-f $aslocal && -r _ && !($force & 1)){
3428         my $size;
3429         if ($size = -s $aslocal) {
3430             $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
3431             return $aslocal;
3432         } else {
3433             # empty file from a previous unsuccessful attempt to download it
3434             unlink $aslocal or
3435                 $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
3436                                        "could not remove.");
3437         }
3438     }
3439     my($maybe_restore) = 0;
3440     if (-f $aslocal){
3441         rename $aslocal, "$aslocal.bak$$";
3442         $maybe_restore++;
3443     }
3444
3445     my($aslocal_dir) = File::Basename::dirname($aslocal);
3446     File::Path::mkpath($aslocal_dir);
3447     $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
3448         qq{directory "$aslocal_dir".
3449     I\'ll continue, but if you encounter problems, they may be due
3450     to insufficient permissions.\n}) unless -w $aslocal_dir;
3451
3452     # Inheritance is not easier to manage than a few if/else branches
3453     if ($CPAN::META->has_usable('LWP::UserAgent')) {
3454         unless ($Ua) {
3455             CPAN::LWP::UserAgent->config;
3456             eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
3457             if ($@) {
3458                 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
3459                     if $CPAN::DEBUG;
3460             } else {
3461                 my($var);
3462                 $Ua->proxy('ftp',  $var)
3463                     if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
3464                 $Ua->proxy('http', $var)
3465                     if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
3466
3467
3468 # >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
3469 #
3470 #  > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
3471 #  > use ones that require basic autorization.
3472 #
3473 #  > Example of when I use it manually in my own stuff:
3474 #
3475 #  > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
3476 #  > $req->proxy_authorization_basic("username","password");
3477 #  > $res = $ua->request($req);
3478 #
3479
3480                 $Ua->no_proxy($var)
3481                     if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
3482             }
3483         }
3484     }
3485     for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
3486         $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
3487     }
3488
3489     # Try the list of urls for each single object. We keep a record
3490     # where we did get a file from
3491     my(@reordered,$last);
3492     my $ccurllist = $self->_get_urllist;
3493     $last = $#$ccurllist;
3494     if ($force & 2) { # local cpans probably out of date, don't reorder
3495         @reordered = (0..$last);
3496     } else {
3497         @reordered =
3498             sort {
3499                 (substr($ccurllist->[$b],0,4) eq "file")
3500                     <=>
3501                 (substr($ccurllist->[$a],0,4) eq "file")
3502                     or
3503                 defined($ThesiteURL)
3504                     and
3505                 ($ccurllist->[$b] eq $ThesiteURL)
3506                     <=>
3507                 ($ccurllist->[$a] eq $ThesiteURL)
3508             } 0..$last;
3509     }
3510     my(@levels);
3511     $Themethod ||= "";
3512     $self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG;
3513     if ($Themethod) {
3514         @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
3515     } else {
3516         @levels = qw/easy hard hardest/;
3517     }
3518     @levels = qw/easy/ if $^O eq 'MacOS';
3519     my($levelno);
3520     local $ENV{FTP_PASSIVE} =
3521         exists $CPAN::Config->{ftp_passive} ?
3522         $CPAN::Config->{ftp_passive} : 1;
3523     my $ret;
3524     my $stats = $self->_new_stats($file);
3525   LEVEL: for $levelno (0..$#levels) {
3526         my $level = $levels[$levelno];
3527         my $method = "host$level";
3528         my @host_seq = $level eq "easy" ?
3529             @reordered : 0..$last;  # reordered has CDROM up front
3530         my @urllist = map { $ccurllist->[$_] } @host_seq;
3531         for my $u (@CPAN::Defaultsites) {
3532             push @urllist, $u unless grep { $_ eq $u } @urllist;
3533         }
3534         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
3535         my $aslocal_tempfile = $aslocal . ".tmp" . $$;
3536         if (my $recommend = $self->_recommend_url_for($file)) {
3537             @urllist = grep { $_ ne $recommend } @urllist;
3538             unshift @urllist, $recommend;
3539         }
3540         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
3541         $ret = $self->$method(\@urllist,$file,$aslocal_tempfile,$stats);
3542         if ($ret) {
3543             CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG;
3544             if ($ret eq $aslocal_tempfile) {
3545                 # if we got it exactly as we asked for, only then we
3546                 # want to rename
3547                 rename $aslocal_tempfile, $aslocal
3548                     or $CPAN::Frontend->mydie("Error while trying to rename ".
3549                                               "'$ret' to '$aslocal': $!");
3550                 $ret = $aslocal;
3551             }
3552             $Themethod = $level;
3553             my $now = time;
3554             # utime $now, $now, $aslocal; # too bad, if we do that, we
3555                                           # might alter a local mirror
3556             $self->debug("level[$level]") if $CPAN::DEBUG;
3557             last LEVEL;
3558         } else {
3559             unlink $aslocal_tempfile;
3560             last if $CPAN::Signal; # need to cleanup
3561         }
3562     }
3563     if ($ret) {
3564         $stats->{filesize} = -s $ret;
3565     }
3566     $self->_add_to_statistics($stats);
3567     if ($ret) {
3568         unlink "$aslocal.bak$$";
3569         return $ret;
3570     }
3571     unless ($CPAN::Signal) {
3572         my(@mess);
3573         local $" = " ";
3574         if (@{$CPAN::Config->{urllist}}) {
3575             push @mess,
3576                 qq{Please check, if the URLs I found in your configuration file \(}.
3577                     join(", ", @{$CPAN::Config->{urllist}}).
3578                         qq{\) are valid.};
3579         } else {
3580             push @mess, qq{Your urllist is empty!};
3581         }
3582         push @mess, qq{The urllist can be edited.},
3583             qq{E.g. with 'o conf urllist push ftp://myurl/'};
3584         $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
3585         $CPAN::Frontend->mywarn("Could not fetch $file\n");
3586         $CPAN::Frontend->mysleep(2);
3587     }
3588     if ($maybe_restore) {
3589         rename "$aslocal.bak$$", $aslocal;
3590         $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
3591                                  $self->ls($aslocal));
3592         return $aslocal;
3593     }
3594     return;
3595 }
3596
3597 sub _set_attempt {
3598     my($self,$stats,$method,$url) = @_;
3599     push @{$stats->{attempts}}, {
3600                                  method => $method,
3601                                  start => _mytime,
3602                                  url => $url,
3603                                 };
3604 }
3605
3606 # package CPAN::FTP;
3607 sub hosteasy {
3608     my($self,$host_seq,$file,$aslocal,$stats) = @_;
3609     my($ro_url);
3610   HOSTEASY: for $ro_url (@$host_seq) {
3611         $self->_set_attempt($stats,"easy",$ro_url);
3612         my $url .= "$ro_url$file";
3613         $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
3614         if ($url =~ /^file:/) {
3615             my $l;
3616             if ($CPAN::META->has_inst('URI::URL')) {
3617                 my $u =  URI::URL->new($url);
3618                 $l = $u->path;
3619             } else { # works only on Unix, is poorly constructed, but
3620                 # hopefully better than nothing.
3621                 # RFC 1738 says fileurl BNF is
3622                 # fileurl = "file://" [ host | "localhost" ] "/" fpath
3623                 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
3624                 # the code
3625                 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
3626                 $l =~ s|^file:||;                   # assume they
3627                                                     # meant
3628                                                     # file://localhost
3629                 $l =~ s|^/||s
3630                     if ! -f $l && $l =~ m|^/\w:|;   # e.g. /P:
3631             }
3632             $self->debug("local file[$l]") if $CPAN::DEBUG;
3633             if ( -f $l && -r _) {
3634                 $ThesiteURL = $ro_url;
3635                 return $l;
3636             }
3637             if ($l =~ /(.+)\.gz$/) {
3638                 my $ungz = $1;
3639                 if ( -f $ungz && -r _) {
3640                     $ThesiteURL = $ro_url;
3641                     return $ungz;
3642                 }
3643             }
3644             # Maybe mirror has compressed it?
3645             if (-f "$l.gz") {
3646                 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
3647                 eval { CPAN::Tarzip->new("$l.gz")->gunzip($aslocal) };
3648                 if ( -f $aslocal) {
3649                     $ThesiteURL = $ro_url;
3650                     return $aslocal;
3651                 }
3652             }
3653         }
3654         $self->debug("it was not a file URL") if $CPAN::DEBUG;
3655         if ($CPAN::META->has_usable('LWP')) {
3656             $CPAN::Frontend->myprint("Fetching with LWP:
3657   $url
3658 ");
3659             unless ($Ua) {
3660                 CPAN::LWP::UserAgent->config;
3661                 eval { $Ua = CPAN::LWP::UserAgent->new; };
3662                 if ($@) {
3663                     $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
3664                 }
3665             }
3666             my $res = $Ua->mirror($url, $aslocal);
3667             if ($res->is_success) {
3668                 $ThesiteURL = $ro_url;
3669                 my $now = time;
3670                 utime $now, $now, $aslocal; # download time is more
3671                                             # important than upload
3672                                             # time
3673                 return $aslocal;
3674             } elsif ($url !~ /\.gz(?!\n)\Z/) {
3675                 my $gzurl = "$url.gz";
3676                 $CPAN::Frontend->myprint("Fetching with LWP:
3677   $gzurl
3678 ");
3679                 $res = $Ua->mirror($gzurl, "$aslocal.gz");
3680                 if ($res->is_success) {
3681                     if (eval {CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)}) {
3682                         $ThesiteURL = $ro_url;
3683                         return $aslocal;
3684                     }
3685                 }
3686             } else {
3687                 $CPAN::Frontend->myprint(sprintf(
3688                                                  "LWP failed with code[%s] message[%s]\n",
3689                                                  $res->code,
3690                                                  $res->message,
3691                                                 ));
3692                 # Alan Burlison informed me that in firewall environments
3693                 # Net::FTP can still succeed where LWP fails. So we do not
3694                 # skip Net::FTP anymore when LWP is available.
3695             }
3696         } else {
3697             $CPAN::Frontend->mywarn("  LWP not available\n");
3698         }
3699         return if $CPAN::Signal;
3700         if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3701             # that's the nice and easy way thanks to Graham
3702             $self->debug("recognized ftp") if $CPAN::DEBUG;
3703             my($host,$dir,$getfile) = ($1,$2,$3);
3704             if ($CPAN::META->has_usable('Net::FTP')) {
3705                 $dir =~ s|/+|/|g;
3706                 $CPAN::Frontend->myprint("Fetching with Net::FTP:
3707   $url
3708 ");
3709                 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
3710                              "aslocal[$aslocal]") if $CPAN::DEBUG;
3711                 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
3712                     $ThesiteURL = $ro_url;
3713                     return $aslocal;
3714                 }
3715                 if ($aslocal !~ /\.gz(?!\n)\Z/) {
3716                     my $gz = "$aslocal.gz";
3717                     $CPAN::Frontend->myprint("Fetching with Net::FTP
3718   $url.gz
3719 ");
3720                     if (CPAN::FTP->ftp_get($host,
3721                                            $dir,
3722                                            "$getfile.gz",
3723                                            $gz) &&
3724                         eval{CPAN::Tarzip->new($gz)->gunzip($aslocal)}
3725                        ){
3726                         $ThesiteURL = $ro_url;
3727                         return $aslocal;
3728                     }
3729                 }
3730                 # next HOSTEASY;
3731             } else {
3732                 CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG;
3733             }
3734         }
3735         if (
3736             UNIVERSAL::can($ro_url,"text")
3737             and
3738             $ro_url->{FROM} eq "USER"
3739            ){
3740             ##address #17973: default URLs should not try to override
3741             ##user-defined URLs just because LWP is not available
3742             my $ret = $self->hosthard([$ro_url],$file,$aslocal,$stats);
3743             return $ret if $ret;
3744         }
3745         return if $CPAN::Signal;
3746     }
3747 }
3748
3749 # package CPAN::FTP;
3750 sub hosthard {
3751   my($self,$host_seq,$file,$aslocal,$stats) = @_;
3752
3753   # Came back if Net::FTP couldn't establish connection (or
3754   # failed otherwise) Maybe they are behind a firewall, but they
3755   # gave us a socksified (or other) ftp program...
3756
3757   my($ro_url);
3758   my($devnull) = $CPAN::Config->{devnull} || "";
3759   # < /dev/null ";
3760   my($aslocal_dir) = File::Basename::dirname($aslocal);
3761   File::Path::mkpath($aslocal_dir);
3762   HOSTHARD: for $ro_url (@$host_seq) {
3763         $self->_set_attempt($stats,"hard",$ro_url);
3764         my $url = "$ro_url$file";
3765         my($proto,$host,$dir,$getfile);
3766
3767         # Courtesy Mark Conty mark_conty@cargill.com change from
3768         # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3769         # to
3770         if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
3771           # proto not yet used
3772           ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
3773         } else {
3774           next HOSTHARD; # who said, we could ftp anything except ftp?
3775         }
3776         next HOSTHARD if $proto eq "file"; # file URLs would have had
3777                                            # success above. Likely a bogus URL
3778
3779         $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
3780
3781         # Try the most capable first and leave ncftp* for last as it only
3782         # does FTP.
3783       DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
3784           my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
3785           next unless defined $funkyftp;
3786           next if $funkyftp =~ /^\s*$/;
3787
3788           my($asl_ungz, $asl_gz);
3789           ($asl_ungz = $aslocal) =~ s/\.gz//;
3790           $asl_gz = "$asl_ungz.gz";
3791
3792           my($src_switch) = "";
3793           my($chdir) = "";
3794           my($stdout_redir) = " > $asl_ungz";
3795           if ($f eq "lynx"){
3796             $src_switch = " -source";
3797           } elsif ($f eq "ncftp"){
3798             $src_switch = " -c";
3799           } elsif ($f eq "wget"){
3800             $src_switch = " -O $asl_ungz";
3801             $stdout_redir = "";
3802           } elsif ($f eq 'curl'){
3803             $src_switch = ' -L -f -s -S --netrc-optional';
3804           }
3805
3806           if ($f eq "ncftpget"){
3807             $chdir = "cd $aslocal_dir && ";
3808             $stdout_redir = "";
3809           }
3810           $CPAN::Frontend->myprint(
3811                                    qq[
3812 Trying with "$funkyftp$src_switch" to get
3813     $url
3814 ]);
3815           my($system) =
3816               "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
3817           $self->debug("system[$system]") if $CPAN::DEBUG;
3818           my($wstatus) = system($system);
3819           if ($f eq "lynx") {
3820               # lynx returns 0 when it fails somewhere
3821               if (-s $asl_ungz) {
3822                   my $content = do { local *FH;
3823                                      open FH, $asl_ungz or die;
3824                                      local $/;
3825                                      <FH> };
3826                   if ($content =~ /^<.*(<title>[45]|Error [45])/si) {
3827                       $CPAN::Frontend->mywarn(qq{
3828 No success, the file that lynx has has downloaded looks like an error message:
3829 $content
3830 });
3831                       $CPAN::Frontend->mysleep(1);
3832                       next DLPRG;
3833                   }
3834               } else {
3835                   $CPAN::Frontend->myprint(qq{
3836 No success, the file that lynx has has downloaded is an empty file.
3837 });
3838                   next DLPRG;
3839               }
3840           }
3841           if ($wstatus == 0) {
3842             if (-s $aslocal) {
3843               # Looks good
3844             } elsif ($asl_ungz ne $aslocal) {
3845               # test gzip integrity
3846               if (eval{CPAN::Tarzip->new($asl_ungz)->gtest}) {
3847                   # e.g. foo.tar is gzipped --> foo.tar.gz
3848                   rename $asl_ungz, $aslocal;
3849               } else {
3850                   eval{CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz)};
3851               }
3852             }
3853             $ThesiteURL = $ro_url;
3854             return $aslocal;
3855           } elsif ($url !~ /\.gz(?!\n)\Z/) {
3856             unlink $asl_ungz if
3857                 -f $asl_ungz && -s _ == 0;
3858             my $gz = "$aslocal.gz";
3859             my $gzurl = "$url.gz";
3860             $CPAN::Frontend->myprint(
3861                                      qq[
3862 Trying with "$funkyftp$src_switch" to get
3863   $url.gz
3864 ]);
3865             my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
3866             $self->debug("system[$system]") if $CPAN::DEBUG;
3867             my($wstatus);
3868             if (($wstatus = system($system)) == 0
3869                 &&
3870                 -s $asl_gz
3871                ) {
3872               # test gzip integrity
3873                 my $ct = eval{CPAN::Tarzip->new($asl_gz)};
3874                 if ($ct && $ct->gtest) {
3875                     $ct->gunzip($aslocal);
3876                 } else {
3877                     # somebody uncompressed file for us?
3878                     rename $asl_ungz, $aslocal;
3879                 }
3880                 $ThesiteURL = $ro_url;
3881                 return $aslocal;
3882             } else {
3883               unlink $asl_gz if -f $asl_gz;
3884             }
3885           } else {
3886             my $estatus = $wstatus >> 8;
3887             my $size = -f $aslocal ?
3888                 ", left\n$aslocal with size ".-s _ :
3889                     "\nWarning: expected file [$aslocal] doesn't exist";
3890             $CPAN::Frontend->myprint(qq{
3891 System call "$system"
3892 returned status $estatus (wstat $wstatus)$size
3893 });
3894           }
3895           return if $CPAN::Signal;
3896         } # transfer programs
3897     } # host
3898 }
3899
3900 # package CPAN::FTP;
3901 sub hosthardest {
3902     my($self,$host_seq,$file,$aslocal,$stats) = @_;
3903
3904     my($ro_url);
3905     my($aslocal_dir) = File::Basename::dirname($aslocal);
3906     File::Path::mkpath($aslocal_dir);
3907     my $ftpbin = $CPAN::Config->{ftp};
3908     unless ($ftpbin && length $ftpbin && MM->maybe_command($ftpbin)) {
3909         $CPAN::Frontend->myprint("No external ftp command available\n\n");
3910         return;
3911     }
3912     $CPAN::Frontend->mywarn(qq{
3913 As a last ressort we now switch to the external ftp command '$ftpbin'
3914 to get '$aslocal'.
3915
3916 Doing so often leads to problems that are hard to diagnose.
3917
3918 If you're victim of such problems, please consider unsetting the ftp
3919 config variable with
3920
3921     o conf ftp ""
3922     o conf commit
3923
3924 });
3925     $CPAN::Frontend->mysleep(2);
3926   HOSTHARDEST: for $ro_url (@$host_seq) {
3927         $self->_set_attempt($stats,"hardest",$ro_url);
3928         my $url = "$ro_url$file";
3929         $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
3930         unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3931             next;
3932         }
3933         my($host,$dir,$getfile) = ($1,$2,$3);
3934         my $timestamp = 0;
3935         my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
3936            $ctime,$blksize,$blocks) = stat($aslocal);
3937         $timestamp = $mtime ||= 0;
3938         my($netrc) = CPAN::FTP::netrc->new;
3939         my($netrcfile) = $netrc->netrc;
3940         my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
3941         my $targetfile = File::Basename::basename($aslocal);
3942         my(@dialog);
3943         push(
3944              @dialog,
3945              "lcd $aslocal_dir",
3946              "cd /",
3947              map("cd $_", split /\//, $dir), # RFC 1738
3948              "bin",
3949              "get $getfile $targetfile",
3950              "quit"
3951             );
3952         if (! $netrcfile) {
3953             CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
3954         } elsif ($netrc->hasdefault || $netrc->contains($host)) {
3955             CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
3956                                 $netrc->hasdefault,
3957                                 $netrc->contains($host))) if $CPAN::DEBUG;
3958             if ($netrc->protected) {
3959                 my $dialog = join "", map { "    $_\n" } @dialog;
3960                 my $netrc_explain;
3961                 if ($netrc->contains($host)) {
3962                     $netrc_explain = "Relying that your .netrc entry for '$host' ".
3963                         "manages the login";
3964                 } else {
3965                     $netrc_explain = "Relying that your default .netrc entry ".
3966                         "manages the login";
3967                 }
3968                 $CPAN::Frontend->myprint(qq{
3969   Trying with external ftp to get
3970     $url
3971   $netrc_explain
3972   Going to send the dialog
3973 $dialog
3974 }
3975                      );
3976                 $self->talk_ftp("$ftpbin$verbose $host",
3977                                 @dialog);
3978                 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
3979                  $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
3980                 $mtime ||= 0;
3981                 if ($mtime > $timestamp) {
3982                     $CPAN::Frontend->myprint("GOT $aslocal\n");
3983                     $ThesiteURL = $ro_url;
3984                     return $aslocal;
3985                 } else {
3986                     $CPAN::Frontend->myprint("Hmm... Still failed!\n");
3987                 }
3988                 return if $CPAN::Signal;
3989             } else {
3990                 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
3991                                         qq{correctly protected.\n});
3992             }
3993         } else {
3994             $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
3995   nor does it have a default entry\n");
3996         }
3997
3998         # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
3999         # then and login manually to host, using e-mail as
4000         # password.
4001         $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
4002         unshift(
4003                 @dialog,
4004                 "open $host",
4005                 "user anonymous $Config::Config{'cf_email'}"
4006                );
4007         my $dialog = join "", map { "    $_\n" } @dialog;
4008         $CPAN::Frontend->myprint(qq{
4009   Trying with external ftp to get
4010     $url
4011   Going to send the dialog
4012 $dialog
4013 }
4014                      );
4015         $self->talk_ftp("$ftpbin$verbose -n", @dialog);
4016         ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4017          $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
4018         $mtime ||= 0;
4019         if ($mtime > $timestamp) {
4020             $CPAN::Frontend->myprint("GOT $aslocal\n");
4021             $ThesiteURL = $ro_url;
4022             return $aslocal;
4023         } else {
4024             $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
4025         }
4026         return if $CPAN::Signal;
4027         $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
4028         $CPAN::Frontend->mysleep(2);
4029     } # host
4030 }
4031
4032 # package CPAN::FTP;
4033 sub talk_ftp {
4034     my($self,$command,@dialog) = @_;
4035     my $fh = FileHandle->new;
4036     $fh->open("|$command") or die "Couldn't open ftp: $!";
4037     foreach (@dialog) { $fh->print("$_\n") }
4038     $fh->close;         # Wait for process to complete
4039     my $wstatus = $?;
4040     my $estatus = $wstatus >> 8;
4041     $CPAN::Frontend->myprint(qq{
4042 Subprocess "|$command"
4043   returned status $estatus (wstat $wstatus)
4044 }) if $wstatus;
4045 }
4046
4047 # find2perl needs modularization, too, all the following is stolen
4048 # from there
4049 # CPAN::FTP::ls
4050 sub ls {
4051     my($self,$name) = @_;
4052     my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
4053      $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
4054
4055     my($perms,%user,%group);
4056     my $pname = $name;
4057
4058     if ($blocks) {
4059         $blocks = int(($blocks + 1) / 2);
4060     }
4061     else {
4062         $blocks = int(($sizemm + 1023) / 1024);
4063     }
4064
4065     if    (-f _) { $perms = '-'; }
4066     elsif (-d _) { $perms = 'd'; }
4067     elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
4068     elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
4069     elsif (-p _) { $perms = 'p'; }
4070     elsif (-S _) { $perms = 's'; }
4071     else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
4072
4073     my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
4074     my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
4075     my $tmpmode = $mode;
4076     my $tmp = $rwx[$tmpmode & 7];
4077     $tmpmode >>= 3;
4078     $tmp = $rwx[$tmpmode & 7] . $tmp;
4079     $tmpmode >>= 3;
4080     $tmp = $rwx[$tmpmode & 7] . $tmp;
4081     substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
4082     substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
4083     substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
4084     $perms .= $tmp;
4085
4086     my $user = $user{$uid} || $uid;   # too lazy to implement lookup
4087     my $group = $group{$gid} || $gid;
4088
4089     my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
4090     my($timeyear);
4091     my($moname) = $moname[$mon];
4092     if (-M _ > 365.25 / 2) {
4093         $timeyear = $year + 1900;
4094     }
4095     else {
4096         $timeyear = sprintf("%02d:%02d", $hour, $min);
4097     }
4098
4099     sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
4100             $ino,
4101                  $blocks,
4102                       $perms,
4103                             $nlink,
4104                                 $user,
4105                                      $group,
4106                                           $sizemm,
4107                                               $moname,
4108                                                  $mday,
4109                                                      $timeyear,
4110                                                          $pname;
4111 }
4112
4113 package CPAN::FTP::netrc;
4114 use strict;
4115
4116 # package CPAN::FTP::netrc;
4117 sub new {
4118     my($class) = @_;
4119     my $home = CPAN::HandleConfig::home;
4120     my $file = File::Spec->catfile($home,".netrc");
4121
4122     my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4123        $atime,$mtime,$ctime,$blksize,$blocks)
4124         = stat($file);
4125     $mode ||= 0;
4126     my $protected = 0;
4127
4128     my($fh,@machines,$hasdefault);
4129     $hasdefault = 0;
4130     $fh = FileHandle->new or die "Could not create a filehandle";
4131
4132     if($fh->open($file)){
4133         $protected = ($mode & 077) == 0;
4134         local($/) = "";
4135       NETRC: while (<$fh>) {
4136             my(@tokens) = split " ", $_;
4137           TOKEN: while (@tokens) {
4138                 my($t) = shift @tokens;
4139                 if ($t eq "default"){
4140                     $hasdefault++;
4141                     last NETRC;
4142                 }
4143                 last TOKEN if $t eq "macdef";
4144                 if ($t eq "machine") {
4145                     push @machines, shift @tokens;
4146                 }
4147             }
4148         }
4149     } else {
4150         $file = $hasdefault = $protected = "";
4151     }
4152
4153     bless {
4154            'mach' => [@machines],
4155            'netrc' => $file,
4156            'hasdefault' => $hasdefault,
4157            'protected' => $protected,
4158           }, $class;
4159 }
4160
4161 # CPAN::FTP::netrc::hasdefault;
4162 sub hasdefault { shift->{'hasdefault'} }
4163 sub netrc      { shift->{'netrc'}      }
4164 sub protected  { shift->{'protected'}  }
4165 sub contains {
4166     my($self,$mach) = @_;
4167     for ( @{$self->{'mach'}} ) {
4168         return 1 if $_ eq $mach;
4169     }
4170     return 0;
4171 }
4172
4173 package CPAN::Complete;
4174 use strict;
4175
4176 sub gnu_cpl {
4177     my($text, $line, $start, $end) = @_;
4178     my(@perlret) = cpl($text, $line, $start);
4179     # find longest common match. Can anybody show me how to peruse
4180     # T::R::Gnu to have this done automatically? Seems expensive.
4181     return () unless @perlret;
4182     my($newtext) = $text;
4183     for (my $i = length($text)+1;;$i++) {
4184         last unless length($perlret[0]) && length($perlret[0]) >= $i;
4185         my $try = substr($perlret[0],0,$i);
4186         my @tries = grep {substr($_,0,$i) eq $try} @perlret;
4187         # warn "try[$try]tries[@tries]";
4188         if (@tries == @perlret) {
4189             $newtext = $try;
4190         } else {
4191             last;
4192         }
4193     }
4194     ($newtext,@perlret);
4195 }
4196
4197 #-> sub CPAN::Complete::cpl ;
4198 sub cpl {
4199     my($word,$line,$pos) = @_;
4200     $word ||= "";
4201     $line ||= "";
4202     $pos ||= 0;
4203     CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4204     $line =~ s/^\s*//;
4205     if ($line =~ s/^(force\s*)//) {
4206         $pos -= length($1);
4207     }
4208     my @return;
4209     if ($pos == 0) {
4210         @return = grep /^$word/, @CPAN::Complete::COMMANDS;
4211     } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
4212         @return = ();
4213     } elsif ($line =~ /^(a|ls)\s/) {
4214         @return = cplx('CPAN::Author',uc($word));
4215     } elsif ($line =~ /^b\s/) {
4216         CPAN::Shell->local_bundles;
4217         @return = cplx('CPAN::Bundle',$word);
4218     } elsif ($line =~ /^d\s/) {
4219         @return = cplx('CPAN::Distribution',$word);
4220     } elsif ($line =~ m/^(
4221                           [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
4222                          )\s/x ) {
4223         if ($word =~ /^Bundle::/) {
4224             CPAN::Shell->local_bundles;
4225         }
4226         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
4227     } elsif ($line =~ /^i\s/) {
4228         @return = cpl_any($word);
4229     } elsif ($line =~ /^reload\s/) {
4230         @return = cpl_reload($word,$line,$pos);
4231     } elsif ($line =~ /^o\s/) {
4232         @return = cpl_option($word,$line,$pos);
4233     } elsif ($line =~ m/^\S+\s/ ) {
4234         # fallback for future commands and what we have forgotten above
4235         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
4236     } else {
4237         @return = ();
4238     }
4239     return @return;
4240 }
4241
4242 #-> sub CPAN::Complete::cplx ;
4243 sub cplx {
4244     my($class, $word) = @_;
4245     if (CPAN::_sqlite_running) {
4246         $CPAN::SQLite->search($class, "^\Q$word\E");
4247     }
4248     sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
4249 }
4250
4251 #-> sub CPAN::Complete::cpl_any ;
4252 sub cpl_any {
4253     my($word) = shift;
4254     return (
4255             cplx('CPAN::Author',$word),
4256             cplx('CPAN::Bundle',$word),
4257             cplx('CPAN::Distribution',$word),
4258             cplx('CPAN::Module',$word),
4259            );
4260 }
4261
4262 #-> sub CPAN::Complete::cpl_reload ;
4263 sub cpl_reload {
4264     my($word,$line,$pos) = @_;
4265     $word ||= "";
4266     my(@words) = split " ", $line;
4267     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4268     my(@ok) = qw(cpan index);
4269     return @ok if @words == 1;
4270     return grep /^\Q$word\E/, @ok if @words == 2 && $word;
4271 }
4272
4273 #-> sub CPAN::Complete::cpl_option ;
4274 sub cpl_option {
4275     my($word,$line,$pos) = @_;
4276     $word ||= "";
4277     my(@words) = split " ", $line;
4278     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4279     my(@ok) = qw(conf debug);
4280     return @ok if @words == 1;
4281     return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
4282     if (0) {
4283     } elsif ($words[1] eq 'index') {
4284         return ();
4285     } elsif ($words[1] eq 'conf') {
4286         return CPAN::HandleConfig::cpl(@_);
4287     } elsif ($words[1] eq 'debug') {
4288         return sort grep /^\Q$word\E/i,
4289             sort keys %CPAN::DEBUG, 'all';
4290     }
4291 }
4292
4293 package CPAN::Index;
4294 use strict;
4295
4296 #-> sub CPAN::Index::force_reload ;
4297 sub force_reload {
4298     my($class) = @_;
4299     $CPAN::Index::LAST_TIME = 0;
4300     $class->reload(1);
4301 }
4302
4303 #-> sub CPAN::Index::reload ;
4304 sub reload {
4305     my($self,$force) = @_;
4306     my $time = time;
4307
4308     # XXX check if a newer one is available. (We currently read it
4309     # from time to time)
4310     for ($CPAN::Config->{index_expire}) {
4311         $_ = 0.001 unless $_ && $_ > 0.001;
4312     }
4313     unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
4314         # debug here when CPAN doesn't seem to read the Metadata
4315         require Carp;
4316         Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
4317     }
4318     unless ($CPAN::META->{PROTOCOL}) {
4319         $self->read_metadata_cache;
4320         $CPAN::META->{PROTOCOL} ||= "1.0";
4321     }
4322     if ( $CPAN::META->{PROTOCOL} < PROTOCOL  ) {
4323         # warn "Setting last_time to 0";
4324         $LAST_TIME = 0; # No warning necessary
4325     }
4326     if ($LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
4327         and ! $force){
4328         # called too often
4329         # CPAN->debug("LAST_TIME[$LAST_TIME]index_expire[$CPAN::Config->{index_expire}]time[$time]");
4330     } elsif (0) {
4331         # IFF we are developing, it helps to wipe out the memory
4332         # between reloads, otherwise it is not what a user expects.
4333         undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
4334         $CPAN::META = CPAN->new;
4335     } else {
4336         my($debug,$t2);
4337         local $LAST_TIME = $time;
4338         local $CPAN::META->{PROTOCOL} = PROTOCOL;
4339
4340         my $needshort = $^O eq "dos";
4341
4342         $self->rd_authindex($self
4343                           ->reload_x(
4344                                      "authors/01mailrc.txt.gz",
4345                                      $needshort ?
4346                                      File::Spec->catfile('authors', '01mailrc.gz') :
4347                                      File::Spec->catfile('authors', '01mailrc.txt.gz'),
4348                                      $force));
4349         $t2 = time;
4350         $debug = "timing reading 01[".($t2 - $time)."]";
4351         $time = $t2;
4352         return if $CPAN::Signal; # this is sometimes lengthy
4353         $self->rd_modpacks($self
4354                          ->reload_x(
4355                                     "modules/02packages.details.txt.gz",
4356                                     $needshort ?
4357                                     File::Spec->catfile('modules', '02packag.gz') :
4358                                     File::Spec->catfile('modules', '02packages.details.txt.gz'),
4359                                     $force));
4360         $t2 = time;
4361         $debug .= "02[".($t2 - $time)."]";
4362         $time = $t2;
4363         return if $CPAN::Signal; # this is sometimes lengthy
4364         $self->rd_modlist($self
4365                         ->reload_x(
4366                                    "modules/03modlist.data.gz",
4367                                    $needshort ?
4368                                    File::Spec->catfile('modules', '03mlist.gz') :
4369                                    File::Spec->catfile('modules', '03modlist.data.gz'),
4370                                    $force));
4371         $self->write_metadata_cache;
4372         $t2 = time;
4373         $debug .= "03[".($t2 - $time)."]";
4374         $time = $t2;
4375         CPAN->debug($debug) if $CPAN::DEBUG;
4376     }
4377     if ($CPAN::Config->{build_dir_reuse}) {
4378         $self->reanimate_build_dir;
4379     }
4380     if (CPAN::_sqlite_running) {
4381         $CPAN::SQLite->reload(time => $time, force => $force)
4382             if not $LAST_TIME;
4383     }
4384     $LAST_TIME = $time;
4385     $CPAN::META->{PROTOCOL} = PROTOCOL;
4386 }
4387
4388 #-> sub CPAN::Index::reanimate_build_dir ;
4389 sub reanimate_build_dir {
4390     my($self) = @_;
4391     unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module}||"YAML")) {
4392         return;
4393     }
4394     return if $HAVE_REANIMATED++;
4395     my $d = $CPAN::Config->{build_dir};
4396     my $dh = DirHandle->new;
4397     opendir $dh, $d or return; # does not exist
4398     my $dirent;
4399     my $i = 0;
4400     my $painted = 0;
4401     my $restored = 0;
4402     $CPAN::Frontend->myprint("Going to read $CPAN::Config->{build_dir}/\n");
4403     my @candidates = map { $_->[0] }
4404         sort { $b->[1] <=> $a->[1] }
4405             map { [ $_, -M File::Spec->catfile($d,$_) ] }
4406                 grep {/\.yml$/} readdir $dh;
4407   DISTRO: for $dirent (@candidates) {
4408         my $y = eval {CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))};
4409         die $@ if $@;
4410         my $c = $y->[0];
4411         if ($c && CPAN->_perl_fingerprint($c->{perl})) {
4412             my $key = $c->{distribution}{ID};
4413             for my $k (keys %{$c->{distribution}}) {
4414                 if ($c->{distribution}{$k}
4415                     && ref $c->{distribution}{$k}
4416                     && UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) {
4417                     $c->{distribution}{$k}{COMMANDID} = $i - @candidates;
4418                 }
4419             }
4420
4421             #we tried to restore only if element already
4422             #exists; but then we do not work with metadata
4423             #turned off.
4424             my $do
4425                 = $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key}
4426                     = $c->{distribution};
4427             delete $do->{badtestcnt};
4428             # $DB::single = 1;
4429             if ($do->{make_test}
4430                 && $do->{build_dir}
4431                 && !$do->{make_test}->failed
4432                 && (
4433                     !$do->{install}
4434                     ||
4435                     $do->{install}->failed
4436                    )
4437                ) {
4438                 $CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME});
4439             }
4440             $restored++;
4441         }
4442         $i++;
4443         while (($painted/76) < ($i/@candidates)) {
4444             $CPAN::Frontend->myprint(".");
4445             $painted++;
4446         }
4447     }
4448     $CPAN::Frontend->myprint(sprintf(
4449                                      "DONE\nFound %s old builds, restored the state of %s\n",
4450                                      @candidates ? sprintf("%d",scalar @candidates) : "no",
4451                                      $restored || "none",
4452                                     ));
4453 }
4454
4455
4456 #-> sub CPAN::Index::reload_x ;
4457 sub reload_x {
4458     my($cl,$wanted,$localname,$force) = @_;
4459     $force |= 2; # means we're dealing with an index here
4460     CPAN::HandleConfig->load; # we should guarantee loading wherever
4461                               # we rely on Config XXX
4462     $localname ||= $wanted;
4463     my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
4464                                          $localname);
4465     if (
4466         -f $abs_wanted &&
4467         -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
4468         !($force & 1)
4469        ) {
4470         my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
4471         $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
4472                    qq{day$s. I\'ll use that.});
4473         return $abs_wanted;
4474     } else {
4475         $force |= 1; # means we're quite serious about it.
4476     }
4477     return CPAN::FTP->localize($wanted,$abs_wanted,$force);
4478 }
4479
4480 #-> sub CPAN::Index::rd_authindex ;
4481 sub rd_authindex {
4482     my($cl, $index_target) = @_;
4483     return unless defined $index_target;
4484     return if CPAN::_sqlite_running;
4485     my @lines;
4486     $CPAN::Frontend->myprint("Going to read $index_target\n");
4487     local(*FH);
4488     tie *FH, 'CPAN::Tarzip', $index_target;
4489     local($/) = "\n";
4490     local($_);
4491     push @lines, split /\012/ while <FH>;
4492     my $i = 0;
4493     my $painted = 0;
4494     foreach (@lines) {
4495         my($userid,$fullname,$email) =
4496             m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/;
4497         $fullname ||= $email;
4498         if ($userid && $fullname && $email){
4499             my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
4500             $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
4501         } else {
4502             CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG;
4503         }
4504         $i++;
4505         while (($painted/76) < ($i/@lines)) {
4506             $CPAN::Frontend->myprint(".");
4507             $painted++;
4508         }
4509         return if $CPAN::Signal;
4510     }
4511     $CPAN::Frontend->myprint("DONE\n");
4512 }
4513
4514 sub userid {
4515   my($self,$dist) = @_;
4516   $dist = $self->{'id'} unless defined $dist;
4517   my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
4518   $ret;
4519 }
4520
4521 #-> sub CPAN::Index::rd_modpacks ;
4522 sub rd_modpacks {
4523     my($self, $index_target) = @_;
4524     return unless defined $index_target;
4525     return if CPAN::_sqlite_running;
4526     $CPAN::Frontend->myprint("Going to read $index_target\n");
4527     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
4528     local $_;
4529     CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
4530     my $slurp = "";
4531     my $chunk;
4532     while (my $bytes = $fh->READ(\$chunk,8192)) {
4533         $slurp.=$chunk;
4534     }
4535     my @lines = split /\012/, $slurp;
4536     CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
4537     undef $fh;
4538     # read header
4539     my($line_count,$last_updated);
4540     while (@lines) {
4541         my $shift = shift(@lines);
4542         last if $shift =~ /^\s*$/;
4543         $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
4544         $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
4545     }
4546     CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
4547     if (not defined $line_count) {
4548
4549         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
4550 Please check the validity of the index file by comparing it to more
4551 than one CPAN mirror. I'll continue but problems seem likely to
4552 happen.\a
4553 });
4554
4555         $CPAN::Frontend->mysleep(5);
4556     } elsif ($line_count != scalar @lines) {
4557
4558         $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
4559 contains a Line-Count header of %d but I see %d lines there. Please
4560 check the validity of the index file by comparing it to more than one
4561 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
4562 $index_target, $line_count, scalar(@lines));
4563
4564     }
4565     if (not defined $last_updated) {
4566
4567         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
4568 Please check the validity of the index file by comparing it to more
4569 than one CPAN mirror. I'll continue but problems seem likely to
4570 happen.\a
4571 });
4572
4573         $CPAN::Frontend->mysleep(5);
4574     } else {
4575
4576         $CPAN::Frontend
4577             ->myprint(sprintf qq{  Database was generated on %s\n},
4578                       $last_updated);
4579         $DATE_OF_02 = $last_updated;
4580
4581         my $age = time;
4582         if ($CPAN::META->has_inst('HTTP::Date')) {
4583             require HTTP::Date;
4584             $age -= HTTP::Date::str2time($last_updated);
4585         } else {
4586             $CPAN::Frontend->mywarn("  HTTP::Date not available\n");
4587             require Time::Local;
4588             my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
4589             $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
4590             $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
4591         }
4592         $age /= 3600*24;
4593         if ($age > 30) {
4594
4595             $CPAN::Frontend
4596                 ->mywarn(sprintf
4597                          qq{Warning: This index file is %d days old.
4598   Please check the host you chose as your CPAN mirror for staleness.
4599   I'll continue but problems seem likely to happen.\a\n},
4600                          $age);
4601
4602         } elsif ($age < -1) {
4603
4604             $CPAN::Frontend
4605                 ->mywarn(sprintf
4606                          qq{Warning: Your system date is %d days behind this index file!
4607   System time:          %s
4608   Timestamp index file: %s
4609   Please fix your system time, problems with the make command expected.\n},
4610                          -$age,
4611                          scalar gmtime,
4612                          $DATE_OF_02,
4613                         );
4614
4615         }
4616     }
4617
4618
4619     # A necessity since we have metadata_cache: delete what isn't
4620     # there anymore
4621     my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
4622     CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
4623     my(%exists);
4624     my $i = 0;
4625     my $painted = 0;
4626     foreach (@lines) {
4627         # before 1.56 we split into 3 and discarded the rest. From
4628         # 1.57 we assign remaining text to $comment thus allowing to
4629         # influence isa_perl
4630         my($mod,$version,$dist,$comment) = split " ", $_, 4;
4631         my($bundle,$id,$userid);
4632
4633         if ($mod eq 'CPAN' &&
4634             ! (
4635                CPAN::Queue->exists('Bundle::CPAN') ||
4636                CPAN::Queue->exists('CPAN')
4637               )
4638            ) {
4639             local($^W)= 0;
4640             if ($version > $CPAN::VERSION){
4641                 $CPAN::Frontend->mywarn(qq{
4642   New CPAN.pm version (v$version) available.
4643   [Currently running version is v$CPAN::VERSION]
4644   You might want to try
4645     install CPAN
4646     reload cpan
4647   to both upgrade CPAN.pm and run the new version without leaving
4648   the current session.
4649
4650 }); #});
4651                 $CPAN::Frontend->mysleep(2);
4652                 $CPAN::Frontend->myprint(qq{\n});
4653             }
4654             last if $CPAN::Signal;
4655         } elsif ($mod =~ /^Bundle::(.*)/) {
4656             $bundle = $1;
4657         }
4658
4659         if ($bundle){
4660             $id =  $CPAN::META->instance('CPAN::Bundle',$mod);
4661             # Let's make it a module too, because bundles have so much
4662             # in common with modules.
4663
4664             # Changed in 1.57_63: seems like memory bloat now without
4665             # any value, so commented out
4666
4667             # $CPAN::META->instance('CPAN::Module',$mod);
4668
4669         } else {
4670
4671             # instantiate a module object
4672             $id = $CPAN::META->instance('CPAN::Module',$mod);
4673
4674         }
4675
4676         # Although CPAN prohibits same name with different version the
4677         # indexer may have changed the version for the same distro
4678         # since the last time ("Force Reindexing" feature)
4679         if ($id->cpan_file ne $dist
4680             ||
4681             $id->cpan_version ne $version
4682            ){
4683             $userid = $id->userid || $self->userid($dist);
4684             $id->set(
4685                      'CPAN_USERID' => $userid,
4686                      'CPAN_VERSION' => $version,
4687                      'CPAN_FILE' => $dist,
4688                     );
4689         }
4690
4691         # instantiate a distribution object
4692         if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
4693           # we do not need CONTAINSMODS unless we do something with
4694           # this dist, so we better produce it on demand.
4695
4696           ## my $obj = $CPAN::META->instance(
4697           ##                              'CPAN::Distribution' => $dist
4698           ##                             );
4699           ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
4700         } else {
4701           $CPAN::META->instance(
4702                                 'CPAN::Distribution' => $dist
4703                                )->set(
4704                                       'CPAN_USERID' => $userid,
4705                                       'CPAN_COMMENT' => $comment,
4706                                      );
4707         }
4708         if ($secondtime) {
4709             for my $name ($mod,$dist) {
4710                 # $self->debug("exists name[$name]") if $CPAN::DEBUG;
4711                 $exists{$name} = undef;
4712             }
4713         }
4714         $i++;
4715         while (($painted/76) < ($i/@lines)) {
4716             $CPAN::Frontend->myprint(".");
4717             $painted++;
4718         }
4719         return if $CPAN::Signal;
4720     }
4721     $CPAN::Frontend->myprint("DONE\n");
4722     if ($secondtime) {
4723         for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
4724             for my $o ($CPAN::META->all_objects($class)) {
4725                 next if exists $exists{$o->{ID}};
4726                 $CPAN::META->delete($class,$o->{ID});
4727                 # CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
4728                 #     if $CPAN::DEBUG;
4729             }
4730         }
4731     }
4732 }
4733
4734 #-> sub CPAN::Index::rd_modlist ;
4735 sub rd_modlist {
4736     my($cl,$index_target) = @_;
4737     return unless defined $index_target;
4738     return if CPAN::_sqlite_running;
4739     $CPAN::Frontend->myprint("Going to read $index_target\n");
4740     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
4741     local $_;
4742     my $slurp = "";
4743     my $chunk;
4744     while (my $bytes = $fh->READ(\$chunk,8192)) {
4745         $slurp.=$chunk;
4746     }
4747     my @eval2 = split /\012/, $slurp;
4748
4749     while (@eval2) {
4750         my $shift = shift(@eval2);
4751         if ($shift =~ /^Date:\s+(.*)/){
4752             if ($DATE_OF_03 eq $1){
4753                 $CPAN::Frontend->myprint("Unchanged.\n");
4754                 return;
4755             }
4756             ($DATE_OF_03) = $1;
4757         }
4758         last if $shift =~ /^\s*$/;
4759     }
4760     push @eval2, q{CPAN::Modulelist->data;};
4761     local($^W) = 0;
4762     my($comp) = Safe->new("CPAN::Safe1");
4763     my($eval2) = join("\n", @eval2);
4764     CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG;
4765     my $ret = $comp->reval($eval2);
4766     Carp::confess($@) if $@;
4767     return if $CPAN::Signal;
4768     my $i = 0;
4769     my $until = keys(%$ret);
4770     my $painted = 0;
4771     CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
4772     for (keys %$ret) {
4773         my $obj = $CPAN::META->instance("CPAN::Module",$_);
4774         delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
4775         $obj->set(%{$ret->{$_}});
4776         $i++;
4777         while (($painted/76) < ($i/$until)) {
4778             $CPAN::Frontend->myprint(".");
4779             $painted++;
4780         }
4781         return if $CPAN::Signal;
4782     }
4783     $CPAN::Frontend->myprint("DONE\n");
4784 }
4785
4786 #-> sub CPAN::Index::write_metadata_cache ;
4787 sub write_metadata_cache {
4788     my($self) = @_;
4789     return unless $CPAN::Config->{'cache_metadata'};
4790     return if CPAN::_sqlite_running;
4791     return unless $CPAN::META->has_usable("Storable");
4792     my $cache;
4793     foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
4794                       CPAN::Distribution)) {
4795         $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
4796     }
4797     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
4798     $cache->{last_time} = $LAST_TIME;
4799     $cache->{DATE_OF_02} = $DATE_OF_02;
4800     $cache->{PROTOCOL} = PROTOCOL;
4801     $CPAN::Frontend->myprint("Going to write $metadata_file\n");
4802     eval { Storable::nstore($cache, $metadata_file) };
4803     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
4804 }
4805
4806 #-> sub CPAN::Index::read_metadata_cache ;
4807 sub read_metadata_cache {
4808     my($self) = @_;
4809     return unless $CPAN::Config->{'cache_metadata'};
4810     return if CPAN::_sqlite_running;
4811     return unless $CPAN::META->has_usable("Storable");
4812     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
4813     return unless -r $metadata_file and -f $metadata_file;
4814     $CPAN::Frontend->myprint("Going to read $metadata_file\n");
4815     my $cache;
4816     eval { $cache = Storable::retrieve($metadata_file) };
4817     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
4818     if (!$cache || !UNIVERSAL::isa($cache, 'HASH')){
4819         $LAST_TIME = 0;
4820         return;
4821     }
4822     if (exists $cache->{PROTOCOL}) {
4823         if (PROTOCOL > $cache->{PROTOCOL}) {
4824             $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
4825                                             "with protocol v%s, requiring v%s\n",
4826                                             $cache->{PROTOCOL},
4827                                             PROTOCOL)
4828                                    );
4829             return;
4830         }
4831     } else {
4832         $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
4833                                 "with protocol v1.0\n");
4834         return;
4835     }
4836     my $clcnt = 0;
4837     my $idcnt = 0;
4838     while(my($class,$v) = each %$cache) {
4839         next unless $class =~ /^CPAN::/;
4840         $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
4841         while (my($id,$ro) = each %$v) {
4842             $CPAN::META->{readwrite}{$class}{$id} ||=
4843                 $class->new(ID=>$id, RO=>$ro);
4844             $idcnt++;
4845         }
4846         $clcnt++;
4847     }
4848     unless ($clcnt) { # sanity check
4849         $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
4850         return;
4851     }
4852     if ($idcnt < 1000) {
4853         $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
4854                                  "in $metadata_file\n");
4855         return;
4856     }
4857     $CPAN::META->{PROTOCOL} ||=
4858         $cache->{PROTOCOL}; # reading does not up or downgrade, but it
4859                             # does initialize to some protocol
4860     $LAST_TIME = $cache->{last_time};
4861     $DATE_OF_02 = $cache->{DATE_OF_02};
4862     $CPAN::Frontend->myprint("  Database was generated on $DATE_OF_02\n")
4863         if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
4864     return;
4865 }
4866
4867 package CPAN::InfoObj;
4868 use strict;
4869
4870 sub ro {
4871     my $self = shift;
4872     exists $self->{RO} and return $self->{RO};
4873 }
4874
4875 #-> sub CPAN::InfoObj::cpan_userid
4876 sub cpan_userid {
4877     my $self = shift;
4878     my $ro = $self->ro;
4879     if ($ro) {
4880         return $ro->{CPAN_USERID} || "N/A";
4881     } else {
4882         $self->debug("ID[$self->{ID}]");
4883         # N/A for bundles found locally
4884         return "N/A";
4885     }
4886 }
4887
4888 sub id { shift->{ID}; }
4889
4890 #-> sub CPAN::InfoObj::new ;
4891 sub new {
4892     my $this = bless {}, shift;
4893     %$this = @_;
4894     $this
4895 }
4896
4897 # The set method may only be used by code that reads index data or
4898 # otherwise "objective" data from the outside world. All session
4899 # related material may do anything else with instance variables but
4900 # must not touch the hash under the RO attribute. The reason is that
4901 # the RO hash gets written to Metadata file and is thus persistent.
4902
4903 #-> sub CPAN::InfoObj::safe_chdir ;
4904 sub safe_chdir {
4905   my($self,$todir) = @_;
4906   # we die if we cannot chdir and we are debuggable
4907   Carp::confess("safe_chdir called without todir argument")
4908         unless defined $todir and length $todir;
4909   if (chdir $todir) {
4910     $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
4911         if $CPAN::DEBUG;
4912   } else {
4913     if (-e $todir) {
4914         unless (-x $todir) {
4915             unless (chmod 0755, $todir) {
4916                 my $cwd = CPAN::anycwd();
4917                 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
4918                                         "permission to change the permission; cannot ".
4919                                         "chdir to '$todir'\n");
4920                 $CPAN::Frontend->mysleep(5);
4921                 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
4922                                        qq{to todir[$todir]: $!});
4923             }
4924         }
4925     } else {
4926         $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n");
4927     }
4928     if (chdir $todir) {
4929       $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
4930           if $CPAN::DEBUG;
4931     } else {
4932       my $cwd = CPAN::anycwd();
4933       $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
4934                              qq{to todir[$todir] (a chmod has been issued): $!});
4935     }
4936   }
4937 }
4938
4939 #-> sub CPAN::InfoObj::set ;
4940 sub set {
4941     my($self,%att) = @_;
4942     my $class = ref $self;
4943
4944     # This must be ||=, not ||, because only if we write an empty
4945     # reference, only then the set method will write into the readonly
4946     # area. But for Distributions that spring into existence, maybe
4947     # because of a typo, we do not like it that they are written into
4948     # the readonly area and made permanent (at least for a while) and
4949     # that is why we do not "allow" other places to call ->set.
4950     unless ($self->id) {
4951         CPAN->debug("Bug? Empty ID, rejecting");
4952         return;
4953     }
4954     my $ro = $self->{RO} =
4955         $CPAN::META->{readonly}{$class}{$self->id} ||= {};
4956
4957     while (my($k,$v) = each %att) {
4958         $ro->{$k} = $v;
4959     }
4960 }
4961
4962 #-> sub CPAN::InfoObj::as_glimpse ;
4963 sub as_glimpse {
4964     my($self) = @_;
4965     my(@m);
4966     my $class = ref($self);
4967     $class =~ s/^CPAN:://;
4968     my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID};
4969     push @m, sprintf "%-15s %s\n", $class, $id;
4970     join "", @m;
4971 }
4972
4973 #-> sub CPAN::InfoObj::as_string ;
4974 sub as_string {
4975     my($self) = @_;
4976     my(@m);
4977     my $class = ref($self);
4978     $class =~ s/^CPAN:://;
4979     push @m, $class, " id = $self->{ID}\n";
4980     my $ro;
4981     unless ($ro = $self->ro) {
4982         if (substr($self->{ID},-1,1) eq ".") { # directory
4983             $ro = +{};
4984         } else {
4985             $CPAN::Frontend->mydie("Unknown object $self->{ID}");
4986         }
4987     }
4988     for (sort keys %$ro) {
4989         # next if m/^(ID|RO)$/;
4990         my $extra = "";
4991         if ($_ eq "CPAN_USERID") {
4992             $extra .= " (";
4993             $extra .= $self->fullname;
4994             my $email; # old perls!
4995             if ($email = $CPAN::META->instance("CPAN::Author",
4996                                                $self->cpan_userid
4997                                               )->email) {
4998                 $extra .= " <$email>";
4999             } else {
5000                 $extra .= " <no email>";
5001             }
5002             $extra .= ")";
5003         } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
5004             push @m, sprintf "    %-12s %s\n", $_, $self->fullname;
5005             next;
5006         }
5007         next unless defined $ro->{$_};
5008         push @m, sprintf "    %-12s %s%s\n", $_, $ro->{$_}, $extra;
5009     }
5010   KEY: for (sort keys %$self) {
5011         next if m/^(ID|RO)$/;
5012         unless (defined $self->{$_}) {
5013             delete $self->{$_};
5014             next KEY;
5015         }
5016         if (ref($self->{$_}) eq "ARRAY") {
5017           push @m, sprintf "    %-12s %s\n", $_, "@{$self->{$_}}";
5018         } elsif (ref($self->{$_}) eq "HASH") {
5019             my $value;
5020             if (/^CONTAINSMODS$/) {
5021                 $value = join(" ",sort keys %{$self->{$_}});
5022             } elsif (/^prereq_pm$/) {
5023                 my @value;
5024                 my $v = $self->{$_};
5025                 for my $x (sort keys %$v) {
5026                     my @svalue;
5027                     for my $y (sort keys %{$v->{$x}}) {
5028                         push @svalue, "$y=>$v->{$x}{$y}";
5029                     }
5030                     push @value, "$x\:" . join ",", @svalue if @svalue;
5031                 }
5032                 $value = join ";", @value;
5033             } else {
5034                 $value = $self->{$_};
5035             }
5036           push @m, sprintf(
5037                            "    %-12s %s\n",
5038                            $_,
5039                            $value,
5040                           );
5041         } else {
5042           push @m, sprintf "    %-12s %s\n", $_, $self->{$_};
5043         }
5044     }
5045     join "", @m, "\n";
5046 }
5047
5048 #-> sub CPAN::InfoObj::fullname ;
5049 sub fullname {
5050     my($self) = @_;
5051     $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
5052 }
5053
5054 #-> sub CPAN::InfoObj::dump ;
5055 sub dump {
5056   my($self, $what) = @_;
5057   unless ($CPAN::META->has_inst("Data::Dumper")) {
5058       $CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
5059   }
5060   local $Data::Dumper::Sortkeys;
5061   $Data::Dumper::Sortkeys = 1;
5062   my $out = Data::Dumper::Dumper($what ? eval $what : $self);
5063   if (length $out > 100000) {
5064       my $fh_pager = FileHandle->new;
5065       local($SIG{PIPE}) = "IGNORE";
5066       my $pager = $CPAN::Config->{'pager'} || "cat";
5067       $fh_pager->open("|$pager")
5068           or die "Could not open pager $pager\: $!";
5069       $fh_pager->print($out);
5070       close $fh_pager;
5071   } else {
5072       $CPAN::Frontend->myprint($out);
5073   }
5074 }
5075
5076 package CPAN::Author;
5077 use strict;
5078
5079 #-> sub CPAN::Author::force
5080 sub force {
5081     my $self = shift;
5082     $self->{force}++;
5083 }
5084
5085 #-> sub CPAN::Author::force
5086 sub unforce {
5087     my $self = shift;
5088     delete $self->{force};
5089 }
5090
5091 #-> sub CPAN::Author::id
5092 sub id {
5093     my $self = shift;
5094     my $id = $self->{ID};
5095     $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
5096     $id;
5097 }
5098
5099 #-> sub CPAN::Author::as_glimpse ;
5100 sub as_glimpse {
5101     my($self) = @_;
5102     my(@m);
5103     my $class = ref($self);
5104     $class =~ s/^CPAN:://;
5105     push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
5106                      $class,
5107                      $self->{ID},
5108                      $self->fullname,
5109                      $self->email);
5110     join "", @m;
5111 }
5112
5113 #-> sub CPAN::Author::fullname ;
5114 sub fullname {
5115     shift->ro->{FULLNAME};
5116 }
5117 *name = \&fullname;
5118
5119 #-> sub CPAN::Author::email ;
5120 sub email    { shift->ro->{EMAIL}; }
5121
5122 #-> sub CPAN::Author::ls ;
5123 sub ls {
5124     my $self = shift;
5125     my $glob = shift || "";
5126     my $silent = shift || 0;
5127     my $id = $self->id;
5128
5129     # adapted from CPAN::Distribution::verifyCHECKSUM ;
5130     my(@csf); # chksumfile
5131     @csf = $self->id =~ /(.)(.)(.*)/;
5132     $csf[1] = join "", @csf[0,1];
5133     $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
5134     my(@dl);
5135     @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
5136     unless (grep {$_->[2] eq $csf[1]} @dl) {
5137         $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
5138         return;
5139     }
5140     @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
5141     unless (grep {$_->[2] eq $csf[2]} @dl) {
5142         $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
5143         return;
5144     }
5145     @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
5146     if ($glob) {
5147         if ($CPAN::META->has_inst("Text::Glob")) {
5148             my $rglob = Text::Glob::glob_to_regex($glob);
5149             @dl = grep { $_->[2] =~ /$rglob/ } @dl;
5150         } else {
5151             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
5152         }
5153     }
5154     $CPAN::Frontend->myprint(join "", map {
5155         sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
5156     } sort { $a->[2] cmp $b->[2] } @dl);
5157     @dl;
5158 }
5159
5160 # returns an array of arrays, the latter contain (size,mtime,filename)
5161 #-> sub CPAN::Author::dir_listing ;
5162 sub dir_listing {
5163     my $self = shift;
5164     my $chksumfile = shift;
5165     my $recursive = shift;
5166     my $may_ftp = shift;
5167
5168     my $lc_want =
5169         File::Spec->catfile($CPAN::Config->{keep_source_where},
5170                             "authors", "id", @$chksumfile);
5171
5172     my $fh;
5173
5174     # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
5175     # hazard.  (Without GPG installed they are not that much better,
5176     # though.)
5177     $fh = FileHandle->new;
5178     if (open($fh, $lc_want)) {
5179         my $line = <$fh>; close $fh;
5180         unlink($lc_want) unless $line =~ /PGP/;
5181     }
5182
5183     local($") = "/";
5184     # connect "force" argument with "index_expire".
5185     my $force = $self->{force};
5186     if (my @stat = stat $lc_want) {
5187         $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
5188     }
5189     my $lc_file;
5190     if ($may_ftp) {
5191         $lc_file = CPAN::FTP->localize(
5192                                        "authors/id/@$chksumfile",
5193                                        $lc_want,
5194                                        $force,
5195                                       );
5196         unless ($lc_file) {
5197             $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
5198             $chksumfile->[-1] .= ".gz";
5199             $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
5200                                            "$lc_want.gz",1);
5201             if ($lc_file) {
5202                 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
5203                 eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
5204             } else {
5205                 return;
5206             }
5207         }
5208     } else {
5209         $lc_file = $lc_want;
5210         # we *could* second-guess and if the user has a file: URL,
5211         # then we could look there. But on the other hand, if they do
5212         # have a file: URL, wy did they choose to set
5213         # $CPAN::Config->{show_upload_date} to false?
5214     }
5215
5216     # adapted from CPAN::Distribution::CHECKSUM_check_file ;
5217     $fh = FileHandle->new;
5218     my($cksum);
5219     if (open $fh, $lc_file){
5220         local($/);
5221         my $eval = <$fh>;
5222         $eval =~ s/\015?\012/\n/g;
5223         close $fh;
5224         my($comp) = Safe->new();
5225         $cksum = $comp->reval($eval);
5226         if ($@) {
5227             rename $lc_file, "$lc_file.bad";
5228             Carp::confess($@) if $@;
5229         }
5230     } elsif ($may_ftp) {
5231         Carp::carp "Could not open '$lc_file' for reading.";
5232     } else {
5233         # Maybe should warn: "You may want to set show_upload_date to a true value"
5234         return;
5235     }
5236     my(@result,$f);
5237     for $f (sort keys %$cksum) {
5238         if (exists $cksum->{$f}{isdir}) {
5239             if ($recursive) {
5240                 my(@dir) = @$chksumfile;
5241                 pop @dir;
5242                 push @dir, $f, "CHECKSUMS";
5243                 push @result, map {
5244                     [$_->[0], $_->[1], "$f/$_->[2]"]
5245                 } $self->dir_listing(\@dir,1,$may_ftp);
5246             } else {
5247                 push @result, [ 0, "-", $f ];
5248             }
5249         } else {
5250             push @result, [
5251                            ($cksum->{$f}{"size"}||0),
5252                            $cksum->{$f}{"mtime"}||"---",
5253                            $f
5254                           ];
5255         }
5256     }
5257     @result;
5258 }
5259
5260 package CPAN::Distribution;
5261 use strict;
5262
5263 # Accessors
5264 sub cpan_comment {
5265     my $self = shift;
5266     my $ro = $self->ro or return;
5267     $ro->{CPAN_COMMENT}
5268 }
5269
5270 # CPAN::Distribution::undelay
5271 sub undelay {
5272     my $self = shift;
5273     delete $self->{later};
5274 }
5275
5276 # add the A/AN/ stuff
5277 # CPAN::Distribution::normalize
5278 sub normalize {
5279     my($self,$s) = @_;
5280     $s = $self->id unless defined $s;
5281     if (substr($s,-1,1) eq ".") {
5282         # using a global because we are sometimes called as static method
5283         if (!$CPAN::META->{LOCK}
5284             && !$CPAN::Have_warned->{"$s is unlocked"}++
5285            ) {
5286             $CPAN::Frontend->mywarn("You are visiting the local directory
5287   '$s'
5288   without lock, take care that concurrent processes do not do likewise.\n");
5289             $CPAN::Frontend->mysleep(1);
5290         }
5291         if ($s eq ".") {
5292             $s = "$CPAN::iCwd/.";
5293         } elsif (File::Spec->file_name_is_absolute($s)) {
5294         } elsif (File::Spec->can("rel2abs")) {
5295             $s = File::Spec->rel2abs($s);
5296         } else {
5297             $CPAN::Frontend->mydie("Your File::Spec is too old, please upgrade File::Spec");
5298         }
5299         CPAN->debug("s[$s]") if $CPAN::DEBUG;
5300         unless ($CPAN::META->exists("CPAN::Distribution", $s)) {
5301             for ($CPAN::META->instance("CPAN::Distribution", $s)) {
5302                 $_->{build_dir} = $s;
5303                 $_->{archived} = "local_directory";
5304                 $_->{unwrapped} = CPAN::Distrostatus->new("YES -- local_directory");
5305             }
5306         }
5307     } elsif (
5308         $s =~ tr|/|| == 1
5309         or
5310         $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
5311        ) {
5312         return $s if $s =~ m:^N/A|^Contact Author: ;
5313         $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
5314             $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
5315         CPAN->debug("s[$s]") if $CPAN::DEBUG;
5316     }
5317     $s;
5318 }
5319
5320 #-> sub CPAN::Distribution::author ;
5321 sub author {
5322     my($self) = @_;
5323     my($authorid);
5324     if (substr($self->id,-1,1) eq ".") {
5325         $authorid = "LOCAL";
5326     } else {
5327         ($authorid) = $self->pretty_id =~ /^([\w\-]+)/;
5328     }
5329     CPAN::Shell->expand("Author",$authorid);
5330 }
5331
5332 # tries to get the yaml from CPAN instead of the distro itself:
5333 # EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels
5334 sub fast_yaml {
5335     my($self) = @_;
5336     my $meta = $self->pretty_id;
5337     $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/;
5338     my(@ls) = CPAN::Shell->globls($meta);
5339     my $norm = $self->normalize($meta);
5340
5341     my($local_file);
5342     my($local_wanted) =
5343         File::Spec->catfile(
5344                             $CPAN::Config->{keep_source_where},
5345                             "authors",
5346                             "id",
5347                             split(/\//,$norm)
5348                            );
5349     $self->debug("Doing localize") if $CPAN::DEBUG;
5350     unless ($local_file =
5351             CPAN::FTP->localize("authors/id/$norm",
5352                                 $local_wanted)) {
5353         $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n");
5354     }
5355     my $yaml = CPAN->_yaml_loadfile($local_file)->[0];
5356 }
5357
5358 #-> sub CPAN::Distribution::cpan_userid
5359 sub cpan_userid {
5360     my $self = shift;
5361     if ($self->{ID} =~ m{[A-Z]/[A-Z\-]{2}/([A-Z\-]+)/}) {
5362         return $1;
5363     }
5364     return $self->SUPER::cpan_userid;
5365 }
5366
5367 #-> sub CPAN::Distribution::pretty_id
5368 sub pretty_id {
5369     my $self = shift;
5370     my $id = $self->id;
5371     return $id unless $id =~ m|^./../|;
5372     substr($id,5);
5373 }
5374
5375 # mark as dirty/clean
5376 #-> sub CPAN::Distribution::color_cmd_tmps ;
5377 sub color_cmd_tmps {
5378     my($self) = shift;
5379     my($depth) = shift || 0;
5380     my($color) = shift || 0;
5381     my($ancestors) = shift || [];
5382     # a distribution needs to recurse into its prereq_pms
5383
5384     return if exists $self->{incommandcolor}
5385         && $self->{incommandcolor}==$color;
5386     if ($depth>=100){
5387         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
5388     }
5389     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5390     my $prereq_pm = $self->prereq_pm;
5391     if (defined $prereq_pm) {
5392       PREREQ: for my $pre (keys %{$prereq_pm->{requires}||{}},
5393                            keys %{$prereq_pm->{build_requires}||{}}) {
5394             next PREREQ if $pre eq "perl";
5395             my $premo;
5396             unless ($premo = CPAN::Shell->expand("Module",$pre)) {
5397                 $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n");
5398                 $CPAN::Frontend->mysleep(2);
5399                 next PREREQ;
5400             }
5401             $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5402         }
5403     }
5404     if ($color==0) {
5405         delete $self->{sponsored_mods};
5406
5407         # as we are at the end of a command, we'll give up this
5408         # reminder of a broken test. Other commands may test this guy
5409         # again. Maybe 'badtestcnt' should be renamed to
5410         # 'makte_test_failed_within_command'?
5411         delete $self->{badtestcnt};
5412     }
5413     $self->{incommandcolor} = $color;
5414 }
5415
5416 #-> sub CPAN::Distribution::as_string ;
5417 sub as_string {
5418   my $self = shift;
5419   $self->containsmods;
5420   $self->upload_date;
5421   $self->SUPER::as_string(@_);
5422 }
5423
5424 #-> sub CPAN::Distribution::containsmods ;
5425 sub containsmods {
5426   my $self = shift;
5427   return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
5428   my $dist_id = $self->{ID};
5429   for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
5430     my $mod_file = $mod->cpan_file or next;
5431     my $mod_id = $mod->{ID} or next;
5432     # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
5433     # sleep 1;
5434     if ($CPAN::Signal) {
5435         delete $self->{CONTAINSMODS};
5436         return;
5437     }
5438     $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
5439   }
5440   keys %{$self->{CONTAINSMODS}||{}};
5441 }
5442
5443 #-> sub CPAN::Distribution::upload_date ;
5444 sub upload_date {
5445   my $self = shift;
5446   return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
5447   my(@local_wanted) = split(/\//,$self->id);
5448   my $filename = pop @local_wanted;
5449   push @local_wanted, "CHECKSUMS";
5450   my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
5451   return unless $author;
5452   my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
5453   return unless @dl;
5454   my($dirent) = grep { $_->[2] eq $filename } @dl;
5455   # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
5456   return unless $dirent->[1];
5457   return $self->{UPLOAD_DATE} = $dirent->[1];
5458 }
5459
5460 #-> sub CPAN::Distribution::uptodate ;
5461 sub uptodate {
5462     my($self) = @_;
5463     my $c;
5464     foreach $c ($self->containsmods) {
5465         my $obj = CPAN::Shell->expandany($c);
5466         unless ($obj->uptodate){
5467             my $id = $self->pretty_id;
5468             $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG;
5469             return 0;
5470         }
5471     }
5472     return 1;
5473 }
5474
5475 #-> sub CPAN::Distribution::called_for ;
5476 sub called_for {
5477     my($self,$id) = @_;
5478     $self->{CALLED_FOR} = $id if defined $id;
5479     return $self->{CALLED_FOR};
5480 }
5481
5482 #-> sub CPAN::Distribution::get ;
5483 sub get {
5484     my($self) = @_;
5485     $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
5486     if (my $goto = $self->prefs->{goto}) {
5487         $CPAN::Frontend->mywarn
5488             (sprintf(
5489                      "delegating to '%s' as specified in prefs file '%s' doc %d\n",
5490                      $goto,
5491                      $self->{prefs_file},
5492                      $self->{prefs_file_doc},
5493                     ));
5494         return $self->goto($goto);
5495     }
5496     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
5497                            ? $ENV{PERL5LIB}
5498                            : ($ENV{PERLLIB} || "");
5499
5500     $CPAN::META->set_perl5lib;
5501     local $ENV{MAKEFLAGS}; # protect us from outer make calls
5502
5503   EXCUSE: {
5504         my @e;
5505         $self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG;
5506         if ($self->prefs->{disabled}) {
5507             my $why = sprintf(
5508                               "Disabled via prefs file '%s' doc %d",
5509                               $self->{prefs_file},
5510                               $self->{prefs_file_doc},
5511                              );
5512             push @e, $why;
5513             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $why");
5514             # note: not intended to be persistent but at least visible
5515             # during this session
5516         } else {
5517             if (exists $self->{build_dir}) {
5518                 # this deserves print, not warn:
5519                 $CPAN::Frontend->myprint("  Has already been unwrapped into directory ".
5520                                          "$self->{build_dir}\n"
5521                                         );
5522                 return;
5523             }
5524
5525             # although we talk about 'force' we shall not test on
5526             # force directly. New model of force tries to refrain from
5527             # direct checking of force.
5528             exists $self->{unwrapped} and (
5529                                            UNIVERSAL::can($self->{unwrapped},"failed") ?
5530                                            $self->{unwrapped}->failed :
5531                                            $self->{unwrapped} =~ /^NO/
5532                                           )
5533                 and push @e, "Unwrapping had some problem, won't try again without force";
5534         }
5535
5536         $CPAN::Frontend->mywarn(join "", map {"$_\n"} @e) and return if @e;
5537     }
5538     my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
5539
5540     #
5541     # Get the file on local disk
5542     #
5543
5544     my($local_file);
5545     my($local_wanted) =
5546         File::Spec->catfile(
5547                             $CPAN::Config->{keep_source_where},
5548                             "authors",
5549                             "id",
5550                             split(/\//,$self->id)
5551                            );
5552
5553     $self->debug("Doing localize") if $CPAN::DEBUG;
5554     unless ($local_file =
5555             CPAN::FTP->localize("authors/id/$self->{ID}",
5556                                 $local_wanted)) {
5557         my $note = "";
5558         if ($CPAN::Index::DATE_OF_02) {
5559             $note = "Note: Current database in memory was generated ".
5560                 "on $CPAN::Index::DATE_OF_02\n";
5561         }
5562         $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
5563     }
5564
5565     $self->debug("local_wanted[$local_wanted]local_file[$local_file]") if $CPAN::DEBUG;
5566     $self->{localfile} = $local_file;
5567     return if $CPAN::Signal;
5568
5569     #
5570     # Check integrity
5571     #
5572     if ($CPAN::META->has_inst("Digest::SHA")) {
5573         $self->debug("Digest::SHA is installed, verifying");
5574         $self->verifyCHECKSUM;
5575     } else {
5576         $self->debug("Digest::SHA is NOT installed");
5577     }
5578     return if $CPAN::Signal;
5579
5580     #
5581     # Create a clean room and go there
5582     #
5583     $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
5584     my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
5585     $self->safe_chdir($builddir);
5586     $self->debug("Removing tmp-$$") if $CPAN::DEBUG;
5587     File::Path::rmtree("tmp-$$");
5588     unless (mkdir "tmp-$$", 0755) {
5589         $CPAN::Frontend->unrecoverable_error(<<EOF);
5590 Couldn't mkdir '$builddir/tmp-$$': $!
5591
5592 Cannot continue: Please find the reason why I cannot make the
5593 directory
5594 $builddir/tmp-$$
5595 and fix the problem, then retry.
5596
5597 EOF
5598     }
5599     if ($CPAN::Signal){
5600         $self->safe_chdir($sub_wd);
5601         return;
5602     }
5603     $self->safe_chdir("tmp-$$");
5604
5605     #
5606     # Unpack the goods
5607     #
5608     my $ct = eval{CPAN::Tarzip->new($local_file)};
5609     unless ($ct) {
5610         $self->{unwrapped} = CPAN::Distrostatus->new("NO");
5611         delete $self->{build_dir};
5612         return;
5613     }
5614     if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i){
5615         $self->{was_uncompressed}++ unless eval{$ct->gtest()};
5616         $self->untar_me($ct);
5617     } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
5618         $self->unzip_me($ct);
5619     } else {
5620         $self->{was_uncompressed}++ unless $ct->gtest();
5621         $local_file = $self->handle_singlefile($local_file);
5622 #    } else {
5623 #       $self->{archived} = "NO";
5624 #        $self->safe_chdir($sub_wd);
5625 #        return;
5626     }
5627
5628     # we are still in the tmp directory!
5629     # Let's check if the package has its own directory.
5630     my $dh = DirHandle->new(File::Spec->curdir)
5631         or Carp::croak("Couldn't opendir .: $!");
5632     my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
5633     $dh->close;
5634     my ($packagedir);
5635     # XXX here we want in each branch File::Temp to protect all build_dir directories
5636     if (CPAN->has_inst("File::Temp")) {
5637         my $tdir_base;
5638         my $from_dir;
5639         my @dirents;
5640         if (@readdir == 1 && -d $readdir[0]) {
5641             $tdir_base = $readdir[0];
5642             $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]);
5643             my $dh2 = DirHandle->new($from_dir)
5644                 or Carp::croak("Couldn't opendir $from_dir: $!");
5645             @dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC??
5646         } else {
5647             my $userid = $self->cpan_userid;
5648             CPAN->debug("userid[$userid]");
5649             if (!$userid or $userid eq "N/A") {
5650                 $userid = "anon";
5651             }
5652             $tdir_base = $userid;
5653             $from_dir = File::Spec->curdir;
5654             @dirents = @readdir;
5655         }
5656         $packagedir = File::Temp::tempdir(
5657                                           "$tdir_base-XXXXXX",
5658                                           DIR => $builddir,
5659                                           CLEANUP => 0,
5660                                          );
5661         my $f;
5662         for $f (@dirents) { # is already without "." and ".."
5663             my $from = File::Spec->catdir($from_dir,$f);
5664             my $to = File::Spec->catdir($packagedir,$f);
5665             unless (File::Copy::move($from,$to)) {
5666                 my $err = $!;
5667                 $from = File::Spec->rel2abs($from);
5668                 Carp::confess("Couldn't move $from to $to: $err");
5669             }
5670         }
5671     } else { # older code below, still better than nothing when there is no File::Temp
5672         my($distdir);
5673         if (@readdir == 1 && -d $readdir[0]) {
5674             $distdir = $readdir[0];
5675             $packagedir = File::Spec->catdir($builddir,$distdir);
5676             $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
5677                 if $CPAN::DEBUG;
5678             -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
5679                                                         "$packagedir\n");
5680             File::Path::rmtree($packagedir);
5681             unless (File::Copy::move($distdir,$packagedir)) {
5682                 $CPAN::Frontend->unrecoverable_error(<<EOF);
5683 Couldn't move '$distdir' to '$packagedir': $!
5684
5685 Cannot continue: Please find the reason why I cannot move
5686 $builddir/tmp-$$/$distdir
5687 to
5688 $packagedir
5689 and fix the problem, then retry
5690
5691 EOF
5692             }
5693             $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
5694                                  $distdir,
5695                                  $packagedir,
5696                                  -e $packagedir,
5697                                  -d $packagedir,
5698                                 )) if $CPAN::DEBUG;
5699         } else {
5700             my $userid = $self->cpan_userid;
5701             CPAN->debug("userid[$userid]") if $CPAN::DEBUG;
5702             if (!$userid or $userid eq "N/A") {
5703                 $userid = "anon";
5704             }
5705             my $pragmatic_dir = $userid . '000';
5706             $pragmatic_dir =~ s/\W_//g;
5707             $pragmatic_dir++ while -d "../$pragmatic_dir";
5708             $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
5709             $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
5710             File::Path::mkpath($packagedir);
5711             my($f);
5712             for $f (@readdir) { # is already without "." and ".."
5713                 my $to = File::Spec->catdir($packagedir,$f);
5714                 File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
5715             }
5716         }
5717     }
5718     if ($CPAN::Signal){
5719         $self->safe_chdir($sub_wd);
5720         return;
5721     }
5722
5723     $self->{build_dir} = $packagedir;
5724     $self->safe_chdir($builddir);
5725     File::Path::rmtree("tmp-$$");
5726
5727     $self->safe_chdir($packagedir);
5728     $self->_signature_business();
5729     $self->safe_chdir($builddir);
5730     return if $CPAN::Signal;
5731
5732
5733     my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
5734     my($mpl_exists) = -f $mpl;
5735     unless ($mpl_exists) {
5736         # NFS has been reported to have racing problems after the
5737         # renaming of a directory in some environments.
5738         # This trick helps.
5739         $CPAN::Frontend->mysleep(1);
5740         my $mpldh = DirHandle->new($packagedir)
5741             or Carp::croak("Couldn't opendir $packagedir: $!");
5742         $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
5743         $mpldh->close;
5744     }
5745     my $prefer_installer = "eumm"; # eumm|mb
5746     if (-f File::Spec->catfile($packagedir,"Build.PL")) {
5747         if ($mpl_exists) { # they *can* choose
5748             $prefer_installer = CPAN::HandleConfig->prefs_lookup($self,
5749                                                                  q{prefer_installer});
5750         } else {
5751             $prefer_installer = "mb";
5752         }
5753     }
5754     return unless $self->patch;
5755     if (lc($prefer_installer) eq "mb") {
5756         $self->{modulebuild} = 1;
5757     } elsif (! $mpl_exists) {
5758         $self->_edge_cases($mpl,$packagedir,$local_file);
5759     }
5760     if ($self->{build_dir}
5761         &&
5762         $CPAN::Config->{build_dir_reuse}
5763        ) {
5764         $self->store_persistent_state;
5765     }
5766
5767     return $self;
5768 }
5769
5770 #-> CPAN::Distribution::store_persistent_state
5771 sub store_persistent_state {
5772     my($self) = @_;
5773     my $dir = $self->{build_dir};
5774     unless (File::Spec->canonpath(File::Basename::dirname($dir))
5775             eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
5776         $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
5777                                 "will not store persistent state\n");
5778         return;
5779     }
5780     my $file = sprintf "%s.yml", $dir;
5781     my $yaml_module = CPAN::_yaml_module;
5782     if ($CPAN::META->has_inst($yaml_module)) {
5783         CPAN->_yaml_dumpfile(
5784                              $file,
5785                              {
5786                               time => time,
5787                               perl => CPAN::_perl_fingerprint,
5788                               distribution => $self,
5789                              }
5790                             );
5791     } else {
5792         $CPAN::Frontend->myprint("Warning (usually harmless): '$yaml_module' not installed, ".
5793                                 "will not store persistent state\n");
5794     }
5795 }
5796
5797 #-> CPAN::Distribution::patch
5798 sub try_download {
5799     my($self,$patch) = @_;
5800     my $norm = $self->normalize($patch);
5801     my($local_wanted) =
5802         File::Spec->catfile(
5803                             $CPAN::Config->{keep_source_where},
5804                             "authors",
5805                             "id",
5806                             split(/\//,$norm),
5807                             );
5808     $self->debug("Doing localize") if $CPAN::DEBUG;
5809     return CPAN::FTP->localize("authors/id/$norm",
5810                                $local_wanted);
5811 }
5812
5813 #-> CPAN::Distribution::patch
5814 sub patch {
5815     my($self) = @_;
5816     $self->debug("checking patches id[$self->{ID}]") if $CPAN::DEBUG;
5817     my $patches = $self->prefs->{patches};
5818     $patches ||= "";
5819     $self->debug("patches[$patches]") if $CPAN::DEBUG;
5820     if ($patches) {
5821         return unless @$patches;
5822         $self->safe_chdir($self->{build_dir});
5823         CPAN->debug("patches[$patches]") if $CPAN::DEBUG;
5824         my $patchbin = $CPAN::Config->{patch};
5825         unless ($patchbin && length $patchbin) {
5826             $CPAN::Frontend->mydie("No external patch command configured\n\n".
5827                                    "Please run 'o conf init /patch/'\n\n");
5828         }
5829         unless (MM->maybe_command($patchbin)) {
5830             $CPAN::Frontend->mydie("No external patch command available\n\n".
5831                                    "Please run 'o conf init /patch/'\n\n");
5832         }
5833         $patchbin = CPAN::HandleConfig->safe_quote($patchbin);
5834         local $ENV{PATCH_GET} = 0; # shall replace -g0 which is not
5835                                    # supported everywhere (and then,
5836                                    # not ever necessary there)
5837         my $stdpatchargs = "-N --fuzz=3";
5838         my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches");
5839         $CPAN::Frontend->myprint("Going to apply $countedpatches:\n");
5840         for my $patch (@$patches) {
5841             unless (-f $patch) {
5842                 if (my $trydl = $self->try_download($patch)) {
5843                     $patch = $trydl;
5844                 } else {
5845                     my $fail = "Could not find patch '$patch'";
5846                     $CPAN::Frontend->mywarn("$fail; cannot continue\n");
5847                     $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
5848                     delete $self->{build_dir};
5849                     return;
5850                 }
5851             }
5852             $CPAN::Frontend->myprint("  $patch\n");
5853             my $readfh = CPAN::Tarzip->TIEHANDLE($patch);
5854
5855             my $pcommand;
5856             my $ppp = $self->_patch_p_parameter($readfh);
5857             if ($ppp eq "applypatch") {
5858                 $pcommand = "$CPAN::Config->{applypatch} -verbose";
5859             } else {
5860                 my $thispatchargs = join " ", $stdpatchargs, $ppp;
5861                 $pcommand = "$patchbin $thispatchargs";
5862             }
5863
5864             $readfh = CPAN::Tarzip->TIEHANDLE($patch); # open again
5865             my $writefh = FileHandle->new;
5866             $CPAN::Frontend->myprint("  $pcommand\n");
5867             unless (open $writefh, "|$pcommand") {
5868                 my $fail = "Could not fork '$pcommand'";
5869                 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
5870                 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
5871                 delete $self->{build_dir};
5872                 return;
5873             }
5874             while (my $x = $readfh->READLINE) {
5875                 print $writefh $x;
5876             }
5877             unless (close $writefh) {
5878                 my $fail = "Could not apply patch '$patch'";
5879                 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
5880                 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
5881                 delete $self->{build_dir};
5882                 return;
5883             }
5884         }
5885         $self->{patched}++;
5886     }
5887     return 1;
5888 }
5889
5890 sub _patch_p_parameter {
5891     my($self,$fh) = @_;
5892     my $cnt_files   = 0;
5893     my $cnt_p0files = 0;
5894     local($_);
5895     while ($_ = $fh->READLINE) {
5896         if (
5897             $CPAN::Config->{applypatch}
5898             &&
5899             /\#\#\#\# ApplyPatch data follows \#\#\#\#/
5900            ) {
5901             return "applypatch"
5902         }
5903         next unless /^[\*\+]{3}\s(\S+)/;
5904         my $file = $1;
5905         $cnt_files++;
5906         $cnt_p0files++ if -f $file;
5907         CPAN->debug("file[$file]cnt_files[$cnt_files]cnt_p0files[$cnt_p0files]")
5908             if $CPAN::DEBUG;
5909     }
5910     return "-p1" unless $cnt_files;
5911     return $cnt_files==$cnt_p0files ? "-p0" : "-p1";
5912 }
5913
5914 #-> sub CPAN::Distribution::_edge_cases
5915 # with "configure" or "Makefile" or single file scripts
5916 sub _edge_cases {
5917     my($self,$mpl,$packagedir,$local_file) = @_;
5918     $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
5919                          $mpl,
5920                          CPAN::anycwd(),
5921                         )) if $CPAN::DEBUG;
5922     my($configure) = File::Spec->catfile($packagedir,"Configure");
5923     if (-f $configure) {
5924         # do we have anything to do?
5925         $self->{configure} = $configure;
5926     } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
5927         $CPAN::Frontend->mywarn(qq{
5928 Package comes with a Makefile and without a Makefile.PL.
5929 We\'ll try to build it with that Makefile then.
5930 });
5931         $self->{writemakefile} = CPAN::Distrostatus->new("YES");
5932         $CPAN::Frontend->mysleep(2);
5933     } else {
5934         my $cf = $self->called_for || "unknown";
5935         if ($cf =~ m|/|) {
5936             $cf =~ s|.*/||;
5937             $cf =~ s|\W.*||;
5938         }
5939         $cf =~ s|[/\\:]||g;     # risk of filesystem damage
5940         $cf = "unknown" unless length($cf);
5941         $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
5942   (The test -f "$mpl" returned false.)
5943   Writing one on our own (setting NAME to $cf)\a\n});
5944         $self->{had_no_makefile_pl}++;
5945         $CPAN::Frontend->mysleep(3);
5946
5947         # Writing our own Makefile.PL
5948
5949         my $script = "";
5950         if ($self->{archived} eq "maybe_pl") {
5951             my $fh = FileHandle->new;
5952             my $script_file = File::Spec->catfile($packagedir,$local_file);
5953             $fh->open($script_file)
5954                 or Carp::croak("Could not open $script_file: $!");
5955             local $/ = "\n";
5956             # name parsen und prereq
5957             my($state) = "poddir";
5958             my($name, $prereq) = ("", "");
5959             while (<$fh>) {
5960                 if ($state eq "poddir" && /^=head\d\s+(\S+)/) {
5961                     if ($1 eq 'NAME') {
5962                         $state = "name";
5963                     } elsif ($1 eq 'PREREQUISITES') {
5964                         $state = "prereq";
5965                     }
5966                 } elsif ($state =~ m{^(name|prereq)$}) {
5967                     if (/^=/) {
5968                         $state = "poddir";
5969                     } elsif (/^\s*$/) {
5970                         # nop
5971                     } elsif ($state eq "name") {
5972                         if ($name eq "") {
5973                             ($name) = /^(\S+)/;
5974                             $state = "poddir";
5975                         }
5976                     } elsif ($state eq "prereq") {
5977                         $prereq .= $_;
5978                     }
5979                 } elsif (/^=cut\b/) {
5980                     last;
5981                 }
5982             }
5983             $fh->close;
5984
5985             for ($name) {
5986                 s{.*<}{};       # strip X<...>
5987                 s{>.*}{};
5988             }
5989             chomp $prereq;
5990             $prereq = join " ", split /\s+/, $prereq;
5991             my($PREREQ_PM) = join("\n", map {
5992                 s{.*<}{};       # strip X<...>
5993                 s{>.*}{};
5994                 if (/[\s\'\"]/) { # prose?
5995                 } else {
5996                     s/[^\w:]$//; # period?
5997                     " "x28 . "'$_' => 0,";
5998                 }
5999             } split /\s*,\s*/, $prereq);
6000
6001             $script = "
6002               EXE_FILES => ['$name'],
6003               PREREQ_PM => {
6004 $PREREQ_PM
6005                            },
6006 ";
6007             if ($name) {
6008                 my $to_file = File::Spec->catfile($packagedir, $name);
6009                 rename $script_file, $to_file
6010                     or die "Can't rename $script_file to $to_file: $!";
6011             }
6012         }
6013
6014         my $fh = FileHandle->new;
6015         $fh->open(">$mpl")
6016             or Carp::croak("Could not open >$mpl: $!");
6017         $fh->print(
6018                    qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
6019 # because there was no Makefile.PL supplied.
6020 # Autogenerated on: }.scalar localtime().qq{
6021
6022 use ExtUtils::MakeMaker;
6023 WriteMakefile(
6024               NAME => q[$cf],$script
6025              );
6026 });
6027         $fh->close;
6028     }
6029 }
6030
6031 #-> CPAN::Distribution::_signature_business
6032 sub _signature_business {
6033     my($self) = @_;
6034     my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
6035                                                       q{check_sigs});
6036     if ($check_sigs) {
6037         if ($CPAN::META->has_inst("Module::Signature")) {
6038             if (-f "SIGNATURE") {
6039                 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
6040                 my $rv = Module::Signature::verify();
6041                 if ($rv != Module::Signature::SIGNATURE_OK() and
6042                     $rv != Module::Signature::SIGNATURE_MISSING()) {
6043                     $CPAN::Frontend->mywarn(
6044                                             qq{\nSignature invalid for }.
6045                                             qq{distribution file. }.
6046                                             qq{Please investigate.\n\n}
6047                                            );
6048
6049                     my $wrap =
6050                         sprintf(qq{I'd recommend removing %s. Its signature
6051 is invalid. Maybe you have configured your 'urllist' with
6052 a bad URL. Please check this array with 'o conf urllist', and
6053 retry. For more information, try opening a subshell with
6054   look %s
6055 and there run
6056   cpansign -v
6057 },
6058                                 $self->{localfile},
6059                                 $self->pretty_id,
6060                                );
6061                     $self->{signature_verify} = CPAN::Distrostatus->new("NO");
6062                     $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
6063                     $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
6064                 } else {
6065                     $self->{signature_verify} = CPAN::Distrostatus->new("YES");
6066                     $self->debug("Module::Signature has verified") if $CPAN::DEBUG;
6067                 }
6068             } else {
6069                 $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n});
6070             }
6071         } else {
6072             $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
6073         }
6074     }
6075 }
6076
6077 #-> CPAN::Distribution::untar_me ;
6078 sub untar_me {
6079     my($self,$ct) = @_;
6080     $self->{archived} = "tar";
6081     if ($ct->untar()) {
6082         $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6083     } else {
6084         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed");
6085     }
6086 }
6087
6088 # CPAN::Distribution::unzip_me ;
6089 sub unzip_me {
6090     my($self,$ct) = @_;
6091     $self->{archived} = "zip";
6092     if ($ct->unzip()) {
6093         $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6094     } else {
6095         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed");
6096     }
6097     return;
6098 }
6099
6100 sub handle_singlefile {
6101     my($self,$local_file) = @_;
6102
6103     if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ){
6104         $self->{archived} = "pm";
6105     } else {
6106         $self->{archived} = "maybe_pl";
6107     }
6108
6109     my $to = File::Basename::basename($local_file);
6110     if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
6111         if (eval{CPAN::Tarzip->new($local_file)->gunzip($to)}) {
6112             $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6113         } else {
6114             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- uncompressing failed");
6115         }
6116     } else {
6117         File::Copy::cp($local_file,".");
6118         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed");
6119     }
6120     return $to;
6121 }
6122
6123 #-> sub CPAN::Distribution::new ;
6124 sub new {
6125     my($class,%att) = @_;
6126
6127     # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
6128
6129     my $this = { %att };
6130     return bless $this, $class;
6131 }
6132
6133 #-> sub CPAN::Distribution::look ;
6134 sub look {
6135     my($self) = @_;
6136
6137     if ($^O eq 'MacOS') {
6138       $self->Mac::BuildTools::look;
6139       return;
6140     }
6141
6142     if (  $CPAN::Config->{'shell'} ) {
6143         $CPAN::Frontend->myprint(qq{
6144 Trying to open a subshell in the build directory...
6145 });
6146     } else {
6147         $CPAN::Frontend->myprint(qq{
6148 Your configuration does not define a value for subshells.
6149 Please define it with "o conf shell <your shell>"
6150 });
6151         return;
6152     }
6153     my $dist = $self->id;
6154     my $dir;
6155     unless ($dir = $self->dir) {
6156         $self->get;
6157     }
6158     unless ($dir ||= $self->dir) {
6159         $CPAN::Frontend->mywarn(qq{
6160 Could not determine which directory to use for looking at $dist.
6161 });
6162         return;
6163     }
6164     my $pwd  = CPAN::anycwd();
6165     $self->safe_chdir($dir);
6166     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
6167     {
6168         local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
6169         $ENV{CPAN_SHELL_LEVEL} += 1;
6170         my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'});
6171         unless (system($shell) == 0) {
6172             my $code = $? >> 8;
6173             $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
6174         }
6175     }
6176     $self->safe_chdir($pwd);
6177 }
6178
6179 # CPAN::Distribution::cvs_import ;
6180 sub cvs_import {
6181     my($self) = @_;
6182     $self->get;
6183     my $dir = $self->dir;
6184
6185     my $package = $self->called_for;
6186     my $module = $CPAN::META->instance('CPAN::Module', $package);
6187     my $version = $module->cpan_version;
6188
6189     my $userid = $self->cpan_userid;
6190
6191     my $cvs_dir = (split /\//, $dir)[-1];
6192     $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
6193     my $cvs_root =
6194       $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
6195     my $cvs_site_perl =
6196       $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
6197     if ($cvs_site_perl) {
6198         $cvs_dir = "$cvs_site_perl/$cvs_dir";
6199     }
6200     my $cvs_log = qq{"imported $package $version sources"};
6201     $version =~ s/\./_/g;
6202     # XXX cvs: undocumented and unclear how it was meant to work
6203     my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
6204                "$cvs_dir", $userid, "v$version");
6205
6206     my $pwd  = CPAN::anycwd();
6207     chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
6208
6209     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
6210
6211     $CPAN::Frontend->myprint(qq{@cmd\n});
6212     system(@cmd) == 0 or
6213     # XXX cvs
6214         $CPAN::Frontend->mydie("cvs import failed");
6215     chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
6216 }
6217
6218 #-> sub CPAN::Distribution::readme ;
6219 sub readme {
6220     my($self) = @_;
6221     my($dist) = $self->id;
6222     my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
6223     $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
6224     my($local_file);
6225     my($local_wanted) =
6226          File::Spec->catfile(
6227                              $CPAN::Config->{keep_source_where},
6228                              "authors",
6229                              "id",
6230                              split(/\//,"$sans.readme"),
6231                             );
6232     $self->debug("Doing localize") if $CPAN::DEBUG;
6233     $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
6234                                       $local_wanted)
6235         or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
6236
6237     if ($^O eq 'MacOS') {
6238         Mac::BuildTools::launch_file($local_file);
6239         return;
6240     }
6241
6242     my $fh_pager = FileHandle->new;
6243     local($SIG{PIPE}) = "IGNORE";
6244     my $pager = $CPAN::Config->{'pager'} || "cat";
6245     $fh_pager->open("|$pager")
6246         or die "Could not open pager $pager\: $!";
6247     my $fh_readme = FileHandle->new;
6248     $fh_readme->open($local_file)
6249         or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
6250     $CPAN::Frontend->myprint(qq{
6251 Displaying file
6252   $local_file
6253 with pager "$pager"
6254 });
6255     $fh_pager->print(<$fh_readme>);
6256     $fh_pager->close;
6257 }
6258
6259 #-> sub CPAN::Distribution::verifyCHECKSUM ;
6260 sub verifyCHECKSUM {
6261     my($self) = @_;
6262   EXCUSE: {
6263         my @e;
6264         $self->{CHECKSUM_STATUS} ||= "";
6265         $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
6266         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
6267     }
6268     my($lc_want,$lc_file,@local,$basename);
6269     @local = split(/\//,$self->id);
6270     pop @local;
6271     push @local, "CHECKSUMS";
6272     $lc_want =
6273         File::Spec->catfile($CPAN::Config->{keep_source_where},
6274                             "authors", "id", @local);
6275     local($") = "/";
6276     if (my $size = -s $lc_want) {
6277         $self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG;
6278         if ($self->CHECKSUM_check_file($lc_want,1)) {
6279             return $self->{CHECKSUM_STATUS} = "OK";
6280         }
6281     }
6282     $lc_file = CPAN::FTP->localize("authors/id/@local",
6283                                    $lc_want,1);
6284     unless ($lc_file) {
6285         $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
6286         $local[-1] .= ".gz";
6287         $lc_file = CPAN::FTP->localize("authors/id/@local",
6288                                        "$lc_want.gz",1);
6289         if ($lc_file) {
6290             $lc_file =~ s/\.gz(?!\n)\Z//;
6291             eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
6292         } else {
6293             return;
6294         }
6295     }
6296     if ($self->CHECKSUM_check_file($lc_file)) {
6297         return $self->{CHECKSUM_STATUS} = "OK";
6298     }
6299 }
6300
6301 #-> sub CPAN::Distribution::SIG_check_file ;
6302 sub SIG_check_file {
6303     my($self,$chk_file) = @_;
6304     my $rv = eval { Module::Signature::_verify($chk_file) };
6305
6306     if ($rv == Module::Signature::SIGNATURE_OK()) {
6307         $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
6308         return $self->{SIG_STATUS} = "OK";
6309     } else {
6310         $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
6311                                  qq{distribution file. }.
6312                                  qq{Please investigate.\n\n}.
6313                                  $self->as_string,
6314                                 $CPAN::META->instance(
6315                                                         'CPAN::Author',
6316                                                         $self->cpan_userid
6317                                                         )->as_string);
6318
6319         my $wrap = qq{I\'d recommend removing $chk_file. Its signature
6320 is invalid. Maybe you have configured your 'urllist' with
6321 a bad URL. Please check this array with 'o conf urllist', and
6322 retry.};
6323
6324         $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
6325     }
6326 }
6327
6328 #-> sub CPAN::Distribution::CHECKSUM_check_file ;
6329
6330 # sloppy is 1 when we have an old checksums file that maybe is good
6331 # enough
6332
6333 sub CHECKSUM_check_file {
6334     my($self,$chk_file,$sloppy) = @_;
6335     my($cksum,$file,$basename);
6336
6337     $sloppy ||= 0;
6338     $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG;
6339     my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
6340                                                       q{check_sigs});
6341     if ($check_sigs) {
6342         if ($CPAN::META->has_inst("Module::Signature")) {
6343             $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
6344             $self->SIG_check_file($chk_file);
6345         } else {
6346             $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
6347         }
6348     }
6349
6350     $file = $self->{localfile};
6351     $basename = File::Basename::basename($file);
6352     my $fh = FileHandle->new;
6353     if (open $fh, $chk_file){
6354         local($/);
6355         my $eval = <$fh>;
6356         $eval =~ s/\015?\012/\n/g;
6357         close $fh;
6358         my($comp) = Safe->new();
6359         $cksum = $comp->reval($eval);
6360         if ($@) {
6361             rename $chk_file, "$chk_file.bad";
6362             Carp::confess($@) if $@;
6363         }
6364     } else {
6365         Carp::carp "Could not open $chk_file for reading";
6366     }
6367
6368     if (! ref $cksum or ref $cksum ne "HASH") {
6369         $CPAN::Frontend->mywarn(qq{
6370 Warning: checksum file '$chk_file' broken.
6371
6372 When trying to read that file I expected to get a hash reference
6373 for further processing, but got garbage instead.
6374 });
6375         my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
6376         $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
6377         $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken";
6378         return;
6379     } elsif (exists $cksum->{$basename}{sha256}) {
6380         $self->debug("Found checksum for $basename:" .
6381                      "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
6382
6383         open($fh, $file);
6384         binmode $fh;
6385         my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
6386         $fh->close;
6387         $fh = CPAN::Tarzip->TIEHANDLE($file);
6388
6389         unless ($eq) {
6390           my $dg = Digest::SHA->new(256);
6391           my($data,$ref);
6392           $ref = \$data;
6393           while ($fh->READ($ref, 4096) > 0){
6394             $dg->add($data);
6395           }
6396           my $hexdigest = $dg->hexdigest;
6397           $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
6398         }
6399
6400         if ($eq) {
6401           $CPAN::Frontend->myprint("Checksum for $file ok\n");
6402           return $self->{CHECKSUM_STATUS} = "OK";
6403         } else {
6404             $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
6405                                      qq{distribution file. }.
6406                                      qq{Please investigate.\n\n}.
6407                                      $self->as_string,
6408                                      $CPAN::META->instance(
6409                                                            'CPAN::Author',
6410                                                            $self->cpan_userid
6411                                                           )->as_string);
6412
6413             my $wrap = qq{I\'d recommend removing $file. Its
6414 checksum is incorrect. Maybe you have configured your 'urllist' with
6415 a bad URL. Please check this array with 'o conf urllist', and
6416 retry.};
6417
6418             $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
6419
6420             # former versions just returned here but this seems a
6421             # serious threat that deserves a die
6422
6423             # $CPAN::Frontend->myprint("\n\n");
6424             # sleep 3;
6425             # return;
6426         }
6427         # close $fh if fileno($fh);
6428     } else {
6429         return if $sloppy;
6430         unless ($self->{CHECKSUM_STATUS}) {
6431             $CPAN::Frontend->mywarn(qq{
6432 Warning: No checksum for $basename in $chk_file.
6433
6434 The cause for this may be that the file is very new and the checksum
6435 has not yet been calculated, but it may also be that something is
6436 going awry right now.
6437 });
6438             my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes");
6439             $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
6440         }
6441         $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file";
6442         return;
6443     }
6444 }
6445
6446 #-> sub CPAN::Distribution::eq_CHECKSUM ;
6447 sub eq_CHECKSUM {
6448     my($self,$fh,$expect) = @_;
6449     if ($CPAN::META->has_inst("Digest::SHA")) {
6450         my $dg = Digest::SHA->new(256);
6451         my($data);
6452         while (read($fh, $data, 4096)){
6453             $dg->add($data);
6454         }
6455         my $hexdigest = $dg->hexdigest;
6456         # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
6457         return $hexdigest eq $expect;
6458     }
6459     return 1;
6460 }
6461
6462 #-> sub CPAN::Distribution::force ;
6463
6464 # Both CPAN::Modules and CPAN::Distributions know if "force" is in
6465 # effect by autoinspection, not by inspecting a global variable. One
6466 # of the reason why this was chosen to work that way was the treatment
6467 # of dependencies. They should not automatically inherit the force
6468 # status. But this has the downside that ^C and die() will return to
6469 # the prompt but will not be able to reset the force_update
6470 # attributes. We try to correct for it currently in the read_metadata
6471 # routine, and immediately before we check for a Signal. I hope this
6472 # works out in one of v1.57_53ff
6473
6474 # "Force get forgets previous error conditions"
6475
6476 #-> sub CPAN::Distribution::fforce ;
6477 sub fforce {
6478   my($self, $method) = @_;
6479   $self->force($method,1);
6480 }
6481
6482 #-> sub CPAN::Distribution::force ;
6483 sub force {
6484   my($self, $method,$fforce) = @_;
6485   my %phase_map = (
6486                    get => [
6487                            "unwrapped",
6488                            "build_dir",
6489                            "archived",
6490                            "localfile",
6491                            "CHECKSUM_STATUS",
6492                            "signature_verify",
6493                            "prefs",
6494                            "prefs_file",
6495                            "prefs_file_doc",
6496                           ],
6497                    make => [
6498                             "writemakefile",
6499                             "make",
6500                             "modulebuild",
6501                             "prereq_pm",
6502                             "prereq_pm_detected",
6503                            ],
6504                    test => [
6505                             "badtestcnt",
6506                             "make_test",
6507                            ],
6508                    install => [
6509                                "install",
6510                               ],
6511                    unknown => [
6512                                "reqtype",
6513                                "yaml_content",
6514                               ],
6515                   );
6516   my $methodmatch = 0;
6517   my $ldebug = 0;
6518  PHASE: for my $phase (qw(unknown get make test install)) { # order matters
6519       $methodmatch = 1 if $fforce || $phase eq $method;
6520       next unless $methodmatch;
6521     ATTRIBUTE: for my $att (@{$phase_map{$phase}}) {
6522           if ($phase eq "get") {
6523               if (substr($self->id,-1,1) eq "."
6524                   && $att =~ /(unwrapped|build_dir|archived)/ ) {
6525                   # cannot be undone for local distros
6526                   next ATTRIBUTE;
6527               }
6528               if ($att eq "build_dir"
6529                   && $self->{build_dir}
6530                   && $CPAN::META->{is_tested}
6531                  ) {
6532                   delete $CPAN::META->{is_tested}{$self->{build_dir}};
6533               }
6534           } elsif ($phase eq "test") {
6535               if ($att eq "make_test"
6536                   && $self->{make_test}
6537                   && $self->{make_test}{COMMANDID}
6538                   && $self->{make_test}{COMMANDID} == $CPAN::CurrentCommandId
6539                  ) {
6540                   # endless loop too likely
6541                   next ATTRIBUTE;
6542               }
6543           }
6544           delete $self->{$att};
6545           if ($ldebug || $CPAN::DEBUG) {
6546               # local $CPAN::DEBUG = 16; # Distribution
6547               CPAN->debug(sprintf "id[%s]phase[%s]att[%s]", $self->id, $phase, $att);
6548           }
6549       }
6550   }
6551   if ($method && $method =~ /make|test|install/) {
6552     $self->{force_update} = 1; # name should probably have been force_install
6553   }
6554 }
6555
6556 #-> sub CPAN::Distribution::notest ;
6557 sub notest {
6558   my($self, $method) = @_;
6559   # warn "XDEBUG: set notest for $self $method";
6560   $self->{"notest"}++; # name should probably have been force_install
6561 }
6562
6563 #-> sub CPAN::Distribution::unnotest ;
6564 sub unnotest {
6565   my($self) = @_;
6566   # warn "XDEBUG: deleting notest";
6567   delete $self->{'notest'};
6568 }
6569
6570 #-> sub CPAN::Distribution::unforce ;
6571 sub unforce {
6572   my($self) = @_;
6573   delete $self->{force_update};
6574 }
6575
6576 #-> sub CPAN::Distribution::isa_perl ;
6577 sub isa_perl {
6578   my($self) = @_;
6579   my $file = File::Basename::basename($self->id);
6580   if ($file =~ m{ ^ perl
6581                   -?
6582                   (5)
6583                   ([._-])
6584                   (
6585                    \d{3}(_[0-4][0-9])?
6586                    |
6587                    \d+\.\d+
6588                   )
6589                   \.tar[._-](?:gz|bz2)
6590                   (?!\n)\Z
6591                 }xs){
6592     return "$1.$3";
6593   } elsif ($self->cpan_comment
6594            &&
6595            $self->cpan_comment =~ /isa_perl\(.+?\)/){
6596     return $1;
6597   }
6598 }
6599
6600
6601 #-> sub CPAN::Distribution::perl ;
6602 sub perl {
6603     my ($self) = @_;
6604     if (! $self) {
6605         use Carp qw(carp);
6606         carp __PACKAGE__ . "::perl was called without parameters.";
6607     }
6608     return CPAN::HandleConfig->safe_quote($CPAN::Perl);
6609 }
6610
6611
6612 #-> sub CPAN::Distribution::make ;
6613 sub make {
6614     my($self) = @_;
6615     if (my $goto = $self->prefs->{goto}) {
6616         return $self->goto($goto);
6617     }
6618     my $make = $self->{modulebuild} ? "Build" : "make";
6619     # Emergency brake if they said install Pippi and get newest perl
6620     if ($self->isa_perl) {
6621       if (
6622           $self->called_for ne $self->id &&
6623           ! $self->{force_update}
6624          ) {
6625         # if we die here, we break bundles
6626         $CPAN::Frontend
6627             ->mywarn(sprintf(
6628                              qq{The most recent version "%s" of the module "%s"
6629 is part of the perl-%s distribution. To install that, you need to run
6630   force install %s   --or--
6631   install %s
6632 },
6633                              $CPAN::META->instance(
6634                                                    'CPAN::Module',
6635                                                    $self->called_for
6636                                                   )->cpan_version,
6637                              $self->called_for,
6638                              $self->isa_perl,
6639                              $self->called_for,
6640                              $self->id,
6641                             ));
6642         $self->{make} = CPAN::Distrostatus->new("NO isa perl");
6643         $CPAN::Frontend->mysleep(1);
6644         return;
6645       }
6646     }
6647     $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
6648     $self->get;
6649     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
6650                            ? $ENV{PERL5LIB}
6651                            : ($ENV{PERLLIB} || "");
6652     $CPAN::META->set_perl5lib;
6653     local $ENV{MAKEFLAGS}; # protect us from outer make calls
6654
6655     if ($CPAN::Signal){
6656       delete $self->{force_update};
6657       return;
6658     }
6659
6660     my $builddir;
6661   EXCUSE: {
6662         my @e;
6663         if (!$self->{archived} || $self->{archived} eq "NO") {
6664             push @e, "Is neither a tar nor a zip archive.";
6665         }
6666
6667         if (!$self->{unwrapped}
6668             || (
6669                 UNIVERSAL::can($self->{unwrapped},"failed") ?
6670                 $self->{unwrapped}->failed :
6671                 $self->{unwrapped} =~ /^NO/
6672                )) {
6673             push @e, "Had problems unarchiving. Please build manually";
6674         }
6675
6676         unless ($self->{force_update}) {
6677             exists $self->{signature_verify} and
6678                 (
6679                  UNIVERSAL::can($self->{signature_verify},"failed") ?
6680                  $self->{signature_verify}->failed :
6681                  $self->{signature_verify} =~ /^NO/
6682                 )
6683                 and push @e, "Did not pass the signature test.";
6684         }
6685
6686         if (exists $self->{writemakefile} &&
6687             (
6688              UNIVERSAL::can($self->{writemakefile},"failed") ?
6689              $self->{writemakefile}->failed :
6690              $self->{writemakefile} =~ /^NO/
6691             )) {
6692             # XXX maybe a retry would be in order?
6693             my $err = UNIVERSAL::can($self->{writemakefile},"text") ?
6694                 $self->{writemakefile}->text :
6695                     $self->{writemakefile};
6696             $err =~ s/^NO\s*//;
6697             $err ||= "Had some problem writing Makefile";
6698             $err .= ", won't make";
6699             push @e, $err;
6700         }
6701
6702         defined $self->{make} and push @e,
6703             "Has already been made";
6704
6705         if (exists $self->{later} and length($self->{later})) {
6706             if ($self->unsat_prereq) {
6707                 push @e, $self->{later};
6708 # RT ticket 18438 raises doubts if the deletion of {later} is valid.
6709 # YAML-0.53 triggered the later hodge-podge here, but my margin notes
6710 # are not sufficient to be sure if we really must/may do the delete
6711 # here. SO I accept the suggested patch for now. If we trigger a bug
6712 # again, I must go into deep contemplation about the {later} flag.
6713
6714 #            } else {
6715 #                delete $self->{later};
6716             }
6717         }
6718
6719         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
6720         $builddir = $self->dir or
6721             $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
6722         unless (chdir $builddir) {
6723             push @e, "Couldn't chdir to '$builddir': $!";
6724         }
6725         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
6726     }
6727     if ($CPAN::Signal){
6728       delete $self->{force_update};
6729       return;
6730     }
6731     $CPAN::Frontend->myprint("\n  CPAN.pm: Going to build ".$self->id."\n\n");
6732     $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
6733
6734     if ($^O eq 'MacOS') {
6735         Mac::BuildTools::make($self);
6736         return;
6737     }
6738
6739     my %env;
6740     while (my($k,$v) = each %ENV) {
6741         next unless defined $v;
6742         $env{$k} = $v;
6743     }
6744     local %ENV = %env;
6745     my $system;
6746     if (my $commandline = $self->prefs->{pl}{commandline}) {
6747         $system = $commandline;
6748         $ENV{PERL} = $^X;
6749     } elsif ($self->{'configure'}) {
6750         $system = $self->{'configure'};
6751     } elsif ($self->{modulebuild}) {
6752         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
6753         $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}";
6754     } else {
6755         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
6756         my $switch = "";
6757 # This needs a handler that can be turned on or off:
6758 #       $switch = "-MExtUtils::MakeMaker ".
6759 #           "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
6760 #           if $] > 5.00310;
6761         my $makepl_arg = $self->make_x_arg("pl");
6762         $system = sprintf("%s%s Makefile.PL%s",
6763                           $perl,
6764                           $switch ? " $switch" : "",
6765                           $makepl_arg ? " $makepl_arg" : "",
6766                          );
6767     }
6768     if (my $env = $self->prefs->{pl}{env}) {
6769         for my $e (keys %$env) {
6770             $ENV{$e} = $env->{$e};
6771         }
6772     }
6773     if (exists $self->{writemakefile}) {
6774     } else {
6775         local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
6776         my($ret,$pid);
6777         $@ = "";
6778         my $go_via_alarm;
6779         if ($CPAN::Config->{inactivity_timeout}) {
6780             require Config;
6781             if ($Config::Config{d_alarm}
6782                 &&
6783                 $Config::Config{d_alarm} eq "define"
6784                ) {
6785                 $go_via_alarm++
6786             } else {
6787                 $CPAN::Frontend->mywarn("Warning: you have configured the config ".
6788                                         "variable 'inactivity_timeout' to ".
6789                                         "'$CPAN::Config->{inactivity_timeout}'. But ".
6790                                         "on this machine the system call 'alarm' ".
6791                                         "isn't available. This means that we cannot ".
6792                                         "provide the feature of intercepting long ".
6793                                         "waiting code and will turn this feature off.\n"
6794                                        );
6795                 $CPAN::Config->{inactivity_timeout} = 0;
6796             }
6797         }
6798         if ($go_via_alarm) {
6799             eval {
6800                 alarm $CPAN::Config->{inactivity_timeout};
6801                 local $SIG{CHLD}; # = sub { wait };
6802                 if (defined($pid = fork)) {
6803                     if ($pid) { #parent
6804                         # wait;
6805                         waitpid $pid, 0;
6806                     } else {    #child
6807                         # note, this exec isn't necessary if
6808                         # inactivity_timeout is 0. On the Mac I'd
6809                         # suggest, we set it always to 0.
6810                         exec $system;
6811                     }
6812                 } else {
6813                     $CPAN::Frontend->myprint("Cannot fork: $!");
6814                     return;
6815                 }
6816             };
6817             alarm 0;
6818             if ($@){
6819                 kill 9, $pid;
6820                 waitpid $pid, 0;
6821                 my $err = "$@";
6822                 $CPAN::Frontend->myprint($err);
6823                 $self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
6824                 $@ = "";
6825                 return;
6826             }
6827         } else {
6828             if (my $expect_model = $self->_prefs_with_expect("pl")) {
6829                 $ret = $self->_run_via_expect($system,$expect_model);
6830                 if (! defined $ret
6831                     && $self->{writemakefile}
6832                     && $self->{writemakefile}->failed) {
6833                     # timeout
6834                     return;
6835                 }
6836             } else {
6837                 $ret = system($system);
6838             }
6839             if ($ret != 0) {
6840                 $self->{writemakefile} = CPAN::Distrostatus
6841                     ->new("NO '$system' returned status $ret");
6842                 $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
6843                 $self->store_persistent_state;
6844                 $self->store_persistent_state;
6845                 return;
6846             }
6847         }
6848         if (-f "Makefile" || -f "Build") {
6849           $self->{writemakefile} = CPAN::Distrostatus->new("YES");
6850           delete $self->{make_clean}; # if cleaned before, enable next
6851         } else {
6852           $self->{writemakefile} = CPAN::Distrostatus
6853               ->new(qq{NO -- Unknown reason});
6854         }
6855     }
6856     if ($CPAN::Signal){
6857       delete $self->{force_update};
6858       return;
6859     }
6860     if (my @prereq = $self->unsat_prereq){
6861         if ($prereq[0][0] eq "perl") {
6862             my $need = "requires perl '$prereq[0][1]'";
6863             my $id = $self->pretty_id;
6864             $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
6865             $self->{make} = CPAN::Distrostatus->new("NO $need");
6866             $self->store_persistent_state;
6867             return;
6868         } else {
6869             return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
6870         }
6871     }
6872     if ($CPAN::Signal){
6873       delete $self->{force_update};
6874       return;
6875     }
6876     if (my $commandline = $self->prefs->{make}{commandline}) {
6877         $system = $commandline;
6878         $ENV{PERL} = $^X;
6879     } else {
6880         if ($self->{modulebuild}) {
6881             unless (-f "Build") {
6882                 my $cwd = CPAN::anycwd();
6883                 $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
6884                                         " in cwd[$cwd]. Danger, Will Robinson!");
6885                 $CPAN::Frontend->mysleep(5);
6886             }
6887             $system = join " ", $self->_build_command(), $CPAN::Config->{mbuild_arg};
6888         } else {
6889             $system = join " ", $self->_make_command(),  $CPAN::Config->{make_arg};
6890         }
6891         $system =~ s/\s+$//;
6892         my $make_arg = $self->make_x_arg("make");
6893         $system = sprintf("%s%s",
6894                           $system,
6895                           $make_arg ? " $make_arg" : "",
6896                          );
6897     }
6898     if (my $env = $self->prefs->{make}{env}) { # overriding the local
6899                                                # ENV of PL, not the
6900                                                # outer ENV, but
6901                                                # unlikely to be a risk
6902         for my $e (keys %$env) {
6903             $ENV{$e} = $env->{$e};
6904         }
6905     }
6906     my $expect_model = $self->_prefs_with_expect("make");
6907     my $want_expect = 0;
6908     if ( $expect_model && @{$expect_model->{talk}} ) {
6909         my $can_expect = $CPAN::META->has_inst("Expect");
6910         if ($can_expect) {
6911             $want_expect = 1;
6912         } else {
6913             $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
6914                                     "system()\n");
6915         }
6916     }
6917     my $system_ok;
6918     if ($want_expect) {
6919         $system_ok = $self->_run_via_expect($system,$expect_model) == 0;
6920     } else {
6921         $system_ok = system($system) == 0;
6922     }
6923     $self->introduce_myself;
6924     if ( $system_ok ) {
6925          $CPAN::Frontend->myprint("  $system -- OK\n");
6926          $self->{make} = CPAN::Distrostatus->new("YES");
6927     } else {
6928          $self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
6929          $self->{make} = CPAN::Distrostatus->new("NO");
6930          $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
6931     }
6932     $self->store_persistent_state;
6933 }
6934
6935 # CPAN::Distribution::_run_via_expect
6936 sub _run_via_expect {
6937     my($self,$system,$expect_model) = @_;
6938     CPAN->debug("system[$system]expect_model[$expect_model]") if $CPAN::DEBUG;
6939     if ($CPAN::META->has_inst("Expect")) {
6940         my $expo = Expect->new;  # expo Expect object;
6941         $expo->spawn($system);
6942         $expect_model->{mode} ||= "deterministic";
6943         if ($expect_model->{mode} eq "deterministic") {
6944             return $self->_run_via_expect_deterministic($expo,$expect_model);
6945         } elsif ($expect_model->{mode} eq "anyorder") {
6946             return $self->_run_via_expect_anyorder($expo,$expect_model);
6947         } else {
6948             die "Panic: Illegal expect mode: $expect_model->{mode}";
6949         }
6950     } else {
6951         $CPAN::Frontend->mywarn("Expect not installed, falling back to system()\n");
6952         return system($system);
6953     }
6954 }
6955
6956 sub _run_via_expect_anyorder {
6957     my($self,$expo,$expect_model) = @_;
6958     my $timeout = $expect_model->{timeout} || 5;
6959     my @expectacopy = @{$expect_model->{talk}}; # we trash it!
6960     my $but = "";
6961   EXPECT: while () {
6962         my($eof,$ran_into_timeout);
6963         my @match = $expo->expect($timeout,
6964                                   [ eof => sub {
6965                                         $eof++;
6966                                     } ],
6967                                   [ timeout => sub {
6968                                         $ran_into_timeout++;
6969                                     } ],
6970                                   -re => eval"qr{.}",
6971                                  );
6972         if ($match[2]) {
6973             $but .= $match[2];
6974         }
6975         $but .= $expo->clear_accum;
6976         if ($eof) {
6977             $expo->soft_close;
6978             return $expo->exitstatus();
6979         } elsif ($ran_into_timeout) {
6980             # warn "DEBUG: they are asking a question, but[$but]";
6981             for (my $i = 0; $i <= $#expectacopy; $i+=2) {
6982                 my($next,$send) = @expectacopy[$i,$i+1];
6983                 my $regex = eval "qr{$next}";
6984                 # warn "DEBUG: will compare with regex[$regex].";
6985                 if ($but =~ /$regex/) {
6986                     # warn "DEBUG: will send send[$send]";
6987                     $expo->send($send);
6988                     splice @expectacopy, $i, 2; # never allow reusing an QA pair
6989                     next EXPECT;
6990                 }
6991             }
6992             my $why = "could not answer a question during the dialog";
6993             $CPAN::Frontend->mywarn("Failing: $why\n");
6994             $self->{writemakefile} =
6995                 CPAN::Distrostatus->new("NO $why");
6996             return;
6997         }
6998     }
6999 }
7000
7001 sub _run_via_expect_deterministic {
7002     my($self,$expo,$expect_model) = @_;
7003     my $ran_into_timeout;
7004     my $timeout = $expect_model->{timeout} || 15; # currently unsettable
7005     my $expecta = $expect_model->{talk};
7006   EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) {
7007         my($re,$send) = @$expecta[$i,$i+1];
7008         CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG;
7009         my $regex = eval "qr{$re}";
7010         $expo->expect($timeout,
7011                       [ eof => sub {
7012                             my $but = $expo->clear_accum;
7013                             $CPAN::Frontend->mywarn("EOF (maybe harmless)
7014 expected[$regex]\nbut[$but]\n\n");
7015                             last EXPECT;
7016                         } ],
7017                       [ timeout => sub {
7018                             my $but = $expo->clear_accum;
7019                             $CPAN::Frontend->mywarn("TIMEOUT
7020 expected[$regex]\nbut[$but]\n\n");
7021                             $ran_into_timeout++;
7022                         } ],
7023                       -re => $regex);
7024         if ($ran_into_timeout){
7025             # note that the caller expects 0 for success
7026             $self->{writemakefile} =
7027                 CPAN::Distrostatus->new("NO timeout during expect dialog");
7028             return;
7029         }
7030         $expo->send($send);
7031     }
7032     $expo->soft_close;
7033     return $expo->exitstatus();
7034 }
7035
7036 #-> CPAN::Distribution::_validate_distropref
7037 sub _validate_distropref {
7038     my($self,@args) = @_;
7039     if (
7040         $CPAN::META->has_inst("CPAN::Kwalify")
7041         &&
7042         $CPAN::META->has_inst("Kwalify")
7043        ) {
7044         eval {CPAN::Kwalify::_validate("distroprefs",@args);};
7045         if ($@) {
7046             $CPAN::Frontend->mywarn($@);
7047         }
7048     } else {
7049         CPAN->debug("not validating '@args'") if $CPAN::DEBUG;
7050     }
7051 }
7052
7053 #-> CPAN::Distribution::_find_prefs
7054 sub _find_prefs {
7055     my($self) = @_;
7056     my $distroid = $self->pretty_id;
7057     #CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG;
7058     my $prefs_dir = $CPAN::Config->{prefs_dir};
7059     eval { File::Path::mkpath($prefs_dir); };
7060     if ($@) {
7061         $CPAN::Frontend->mydie("Cannot create directory $prefs_dir");
7062     }
7063     my $yaml_module = CPAN::_yaml_module;
7064     my @extensions;
7065     if ($CPAN::META->has_inst($yaml_module)) {
7066         push @extensions, "yml";
7067     } else {
7068         my @fallbacks;
7069         if ($CPAN::META->has_inst("Data::Dumper")) {
7070             push @extensions, "dd";
7071             push @fallbacks, "Data::Dumper";
7072         }
7073         if ($CPAN::META->has_inst("Storable")) {
7074             push @extensions, "st";
7075             push @fallbacks, "Storable";
7076         }
7077         if (@fallbacks) {
7078             local $" = " and ";
7079             unless ($self->{have_complained_about_missing_yaml}++) {
7080                 $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back ".
7081                                         "to @fallbacks to read prefs '$prefs_dir'\n");
7082             }
7083         } else {
7084             unless ($self->{have_complained_about_missing_yaml}++) {
7085                 $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot ".
7086                                         "read prefs '$prefs_dir'\n");
7087             }
7088         }
7089     }
7090     if (@extensions) {
7091         my $dh = DirHandle->new($prefs_dir)
7092             or die Carp::croak("Couldn't open '$prefs_dir': $!");
7093       DIRENT: for (sort $dh->read) {
7094             next if $_ eq "." || $_ eq "..";
7095             my $exte = join "|", @extensions;
7096             next unless /\.($exte)$/;
7097             my $thisexte = $1;
7098             my $abs = File::Spec->catfile($prefs_dir, $_);
7099             if (-f $abs) {
7100                 #CPAN->debug(sprintf "abs[%s]", $abs) if $CPAN::DEBUG;
7101                 my @distropref;
7102                 if ($thisexte eq "yml") {
7103                     # need no eval because if we have no YAML we do not try to read *.yml
7104                     #CPAN->debug(sprintf "before yaml load abs[%s]", $abs) if $CPAN::DEBUG;
7105                     @distropref = @{CPAN->_yaml_loadfile($abs)};
7106                     #CPAN->debug(sprintf "after yaml load abs[%s]", $abs) if $CPAN::DEBUG;
7107                 } elsif ($thisexte eq "dd") {
7108                     package CPAN::Eval;
7109                     no strict;
7110                     open FH, "<$abs" or $CPAN::Frontend->mydie("Could not open '$abs': $!");
7111                     local $/;
7112                     my $eval = <FH>;
7113                     close FH;
7114                     eval $eval;
7115                     if ($@) {
7116                         $CPAN::Frontend->mydie("Error in distroprefs file $_\: $@");
7117                     }
7118                     my $i = 1;
7119                     while (${"VAR".$i}) {
7120                         push @distropref, ${"VAR".$i};
7121                         $i++;
7122                     }
7123                 } elsif ($thisexte eq "st") {
7124                     # eval because Storable is never forward compatible
7125                     eval { @distropref = @{scalar Storable::retrieve($abs)}; };
7126                     if ($@) {
7127                         $CPAN::Frontend->mywarn("Error reading distroprefs file ".
7128                                                 "$_, skipping\: $@");
7129                         $CPAN::Frontend->mysleep(4);
7130                         next DIRENT;
7131                     }
7132                 }
7133                 # $DB::single=1;
7134                 #CPAN->debug(sprintf "#distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
7135               ELEMENT: for my $y (0..$#distropref) {
7136                     my $distropref = $distropref[$y];
7137                     $self->_validate_distropref($distropref,$abs,$y);
7138                     my $match = $distropref->{match};
7139                     unless ($match) {
7140                         #CPAN->debug("no 'match' in abs[$abs], skipping") if $CPAN::DEBUG;
7141                         next ELEMENT;
7142                     }
7143                     my $ok = 1;
7144                     # do not take the order of C<keys %$match> because
7145                     # "module" is by far the slowest
7146                     for my $sub_attribute (qw(distribution perl module)) {
7147                         next unless exists $match->{$sub_attribute};
7148                         my $qr = eval "qr{$distropref->{match}{$sub_attribute}}";
7149                         if ($sub_attribute eq "module") {
7150                             my $okm = 0;
7151                             #CPAN->debug(sprintf "distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
7152                             my @modules = $self->containsmods;
7153                             #CPAN->debug(sprintf "modules[%s]", join(",",@modules)) if $CPAN::DEBUG;
7154                           MODULE: for my $module (@modules) {
7155                                 $okm ||= $module =~ /$qr/;
7156                                 last MODULE if $okm;
7157                             }
7158                             $ok &&= $okm;
7159                         } elsif ($sub_attribute eq "distribution") {
7160                             my $okd = $distroid =~ /$qr/;
7161                             $ok &&= $okd;
7162                         } elsif ($sub_attribute eq "perl") {
7163                             my $okp = $^X =~ /$qr/;
7164                             $ok &&= $okp;
7165                         } else {
7166                             $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ".
7167                                                    "unknown sub_attribut '$sub_attribute'. ".
7168                                                    "Please ".
7169                                                    "remove, cannot continue.");
7170                         }
7171                         last if $ok == 0; # short circuit
7172                     }
7173                     #CPAN->debug(sprintf "ok[%d]", $ok) if $CPAN::DEBUG;
7174                     if ($ok) {
7175                         return {
7176                                 prefs => $distropref,
7177                                 prefs_file => $abs,
7178                                 prefs_file_doc => $y,
7179                                };
7180                     }
7181
7182                 }
7183             }
7184         }
7185         $dh->close;
7186     }
7187     return;
7188 }
7189
7190 # CPAN::Distribution::prefs
7191 sub prefs {
7192     my($self) = @_;
7193     if (exists $self->{prefs}) {
7194         return $self->{prefs}; # XXX comment out during debugging
7195     }
7196     if ($CPAN::Config->{prefs_dir}) {
7197         CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG;
7198         my $prefs = $self->_find_prefs();
7199         $prefs ||= ""; # avoid warning next line
7200         CPAN->debug("prefs[$prefs]") if $CPAN::DEBUG;
7201         if ($prefs) {
7202             for my $x (qw(prefs prefs_file prefs_file_doc)) {
7203                 $self->{$x} = $prefs->{$x};
7204             }
7205             my $bs = sprintf(
7206                              "%s[%s]",
7207                              File::Basename::basename($self->{prefs_file}),
7208                              $self->{prefs_file_doc},
7209                             );
7210             my $filler1 = "_" x 22;
7211             my $filler2 = int(66 - length($bs))/2;
7212             $filler2 = 0 if $filler2 < 0;
7213             $filler2 = " " x $filler2;
7214             $CPAN::Frontend->myprint("
7215 $filler1 D i s t r o P r e f s $filler1
7216 $filler2 $bs $filler2
7217 ");
7218             $CPAN::Frontend->mysleep(1);
7219             return $self->{prefs};
7220         }
7221     }
7222     return +{};
7223 }
7224
7225 # CPAN::Distribution::make_x_arg
7226 sub make_x_arg {
7227     my($self, $whixh) = @_;
7228     my $make_x_arg;
7229     my $prefs = $self->prefs;
7230     if (
7231         $prefs
7232         && exists $prefs->{$whixh}
7233         && exists $prefs->{$whixh}{args}
7234         && $prefs->{$whixh}{args}
7235        ) {
7236         $make_x_arg = join(" ",
7237                            map {CPAN::HandleConfig
7238                                  ->safe_quote($_)} @{$prefs->{$whixh}{args}},
7239                           );
7240     }
7241     my $what = sprintf "make%s_arg", $whixh eq "make" ? "" : $whixh;
7242     $make_x_arg ||= $CPAN::Config->{$what};
7243     return $make_x_arg;
7244 }
7245
7246 # CPAN::Distribution::_make_command
7247 sub _make_command {
7248     my ($self) = @_;
7249     if ($self) {
7250         return
7251             CPAN::HandleConfig
7252                 ->safe_quote(
7253                              CPAN::HandleConfig->prefs_lookup($self,
7254                                                               q{make})
7255                              || $Config::Config{make}
7256                              || 'make'
7257                             );
7258     } else {
7259         # Old style call, without object. Deprecated
7260         Carp::confess("CPAN::_make_command() used as function. Don't Do That.");
7261         return
7262           safe_quote(undef,
7263                      CPAN::HandleConfig->prefs_lookup($self,q{make})
7264                      || $CPAN::Config->{make}
7265                      || $Config::Config{make}
7266                      || 'make');
7267     }
7268 }
7269
7270 #-> sub CPAN::Distribution::follow_prereqs ;
7271 sub follow_prereqs {
7272     my($self) = shift;
7273     my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
7274     return unless @prereq_tuples;
7275     my @prereq = map { $_->[0] } @prereq_tuples;
7276     my $pretty_id = $self->pretty_id;
7277     my %map = (
7278                b => "build_requires",
7279                r => "requires",
7280                c => "commandline",
7281               );
7282     my($filler1,$filler2,$filler3,$filler4);
7283     my $unsat = "Unsatisfied dependencies detected during";
7284     my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id);
7285     {
7286         my $r = int(($w - length($unsat))/2);
7287         my $l = $w - length($unsat) - $r;
7288         $filler1 = "-"x4 . " "x$l;
7289         $filler2 = " "x$r . "-"x4 . "\n";
7290     }
7291     {
7292         my $r = int(($w - length($pretty_id))/2);
7293         my $l = $w - length($pretty_id) - $r;
7294         $filler3 = "-"x4 . " "x$l;
7295         $filler4 = " "x$r . "-"x4 . "\n";
7296     }
7297     $CPAN::Frontend->
7298         myprint("$filler1 $unsat $filler2".
7299                 "$filler3 $pretty_id $filler4".
7300                 join("", map {"    $_->[0] \[$map{$_->[1]}]\n"} @prereq_tuples),
7301                );
7302     my $follow = 0;
7303     if ($CPAN::Config->{prerequisites_policy} eq "follow") {
7304         $follow = 1;
7305     } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
7306         my $answer = CPAN::Shell::colorable_makemaker_prompt(
7307 "Shall I follow them and prepend them to the queue
7308 of modules we are processing right now?", "yes");
7309         $follow = $answer =~ /^\s*y/i;
7310     } else {
7311         local($") = ", ";
7312         $CPAN::Frontend->
7313             myprint("  Ignoring dependencies on modules @prereq\n");
7314     }
7315     if ($follow) {
7316         my $id = $self->id;
7317         # color them as dirty
7318         for my $p (@prereq) {
7319             # warn "calling color_cmd_tmps(0,1)";
7320             my $any = CPAN::Shell->expandany($p);
7321             if ($any) {
7322                 $any->color_cmd_tmps(0,1);
7323             } else {
7324                 $CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$p'\n");
7325                 $CPAN::Frontend->mysleep(2);
7326             }
7327         }
7328         # queue them and re-queue yourself
7329         CPAN::Queue->jumpqueue([$id,$self->{reqtype}],
7330                                reverse @prereq_tuples);
7331         $self->{later} = "Delayed until after prerequisites";
7332         return 1; # signal success to the queuerunner
7333     }
7334 }
7335
7336 #-> sub CPAN::Distribution::unsat_prereq ;
7337 # return ([Foo=>1],[Bar=>1.2]) for normal modules
7338 # return ([perl=>5.008]) if we need a newer perl than we are running under
7339 sub unsat_prereq {
7340     my($self) = @_;
7341     my $prereq_pm = $self->prereq_pm or return;
7342     my(@need);
7343     my %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}});
7344   NEED: while (my($need_module, $need_version) = each %merged) {
7345         my($available_version,$available_file);
7346         if ($need_module eq "perl") {
7347             $available_version = $];
7348             $available_file = $^X;
7349         } else {
7350             my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
7351             next if $nmo->uptodate;
7352             $available_file = $nmo->available_file;
7353
7354             # if they have not specified a version, we accept any installed one
7355             if (not defined $need_version or
7356                 $need_version eq "0" or
7357                 $need_version eq "undef") {
7358                 next if defined $available_file;
7359             }
7360
7361             $available_version = $nmo->available_version;
7362         }
7363
7364         # We only want to install prereqs if either they're not installed
7365         # or if the installed version is too old. We cannot omit this
7366         # check, because if 'force' is in effect, nobody else will check.
7367         if (defined $available_file) {
7368             my(@all_requirements) = split /\s*,\s*/, $need_version;
7369             local($^W) = 0;
7370             my $ok = 0;
7371           RQ: for my $rq (@all_requirements) {
7372                 if ($rq =~ s|>=\s*||) {
7373                 } elsif ($rq =~ s|>\s*||) {
7374                     # 2005-12: one user
7375                     if (CPAN::Version->vgt($available_version,$rq)){
7376                         $ok++;
7377                     }
7378                     next RQ;
7379                 } elsif ($rq =~ s|!=\s*||) {
7380                     # 2005-12: no user
7381                     if (CPAN::Version->vcmp($available_version,$rq)){
7382                         $ok++;
7383                         next RQ;
7384                     } else {
7385                         last RQ;
7386                     }
7387                 } elsif ($rq =~ m|<=?\s*|) {
7388                     # 2005-12: no user
7389                     $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n");
7390                     $ok++;
7391                     next RQ;
7392                 }
7393                 if (! CPAN::Version->vgt($rq, $available_version)){
7394                     $ok++;
7395                 }
7396                 CPAN->debug(sprintf("need_module[%s]available_file[%s]".
7397                                     "available_version[%s]rq[%s]ok[%d]",
7398                                     $need_module,
7399                                     $available_file,
7400                                     $available_version,
7401                                     CPAN::Version->readable($rq),
7402                                     $ok,
7403                                    )) if $CPAN::DEBUG;
7404             }
7405             next NEED if $ok == @all_requirements;
7406         }
7407
7408         if ($need_module eq "perl") {
7409             return ["perl", $need_version];
7410         }
7411         if ($self->{sponsored_mods}{$need_module}++){
7412             # We have already sponsored it and for some reason it's still
7413             # not available. So we do nothing. Or what should we do?
7414             # if we push it again, we have a potential infinite loop
7415             next;
7416         }
7417         my $needed_as = exists $prereq_pm->{requires}{$need_module} ? "r" : "b";
7418         push @need, [$need_module,$needed_as];
7419     }
7420     @need;
7421 }
7422
7423 #-> sub CPAN::Distribution::read_yaml ;
7424 sub read_yaml {
7425     my($self) = @_;
7426     return $self->{yaml_content} if exists $self->{yaml_content};
7427     my $build_dir = $self->{build_dir};
7428     my $yaml = File::Spec->catfile($build_dir,"META.yml");
7429     $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
7430     return unless -f $yaml;
7431     eval { $self->{yaml_content} = CPAN->_yaml_loadfile($yaml)->[0]; };
7432     if ($@) {
7433         $CPAN::Frontend->mywarn("Could not read ".
7434                                 "'$yaml'. Falling back to other ".
7435                                 "methods to determine prerequisites\n");
7436         return $self->{yaml_content} = undef; # if we die, then we
7437                                               # cannot read YAML's own
7438                                               # META.yml
7439     }
7440     if (not exists $self->{yaml_content}{dynamic_config}
7441         or $self->{yaml_content}{dynamic_config}
7442        ) {
7443         $self->{yaml_content} = undef;
7444     }
7445     $self->debug(sprintf "yaml_content[%s]", $self->{yaml_content} || "UNDEF")
7446         if $CPAN::DEBUG;
7447     return $self->{yaml_content};
7448 }
7449
7450 #-> sub CPAN::Distribution::prereq_pm ;
7451 sub prereq_pm {
7452     my($self) = @_;
7453     $self->{prereq_pm_detected} ||= 0;
7454     CPAN->debug("prereq_pm_detected[$self->{prereq_pm_detected}]") if $CPAN::DEBUG;
7455     return $self->{prereq_pm} if $self->{prereq_pm_detected};
7456     return unless $self->{writemakefile}  # no need to have succeeded
7457                                           # but we must have run it
7458         || $self->{modulebuild};
7459     CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
7460                 $self->{writemakefile}||"",
7461                 $self->{modulebuild}||"",
7462                ) if $CPAN::DEBUG;
7463     my($req,$breq);
7464     if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
7465         $req =  $yaml->{requires} || {};
7466         $breq =  $yaml->{build_requires} || {};
7467         undef $req unless ref $req eq "HASH" && %$req;
7468         if ($req) {
7469             if ($yaml->{generated_by} &&
7470                 $yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
7471                 my $eummv = do { local $^W = 0; $1+0; };
7472                 if ($eummv < 6.2501) {
7473                     # thanks to Slaven for digging that out: MM before
7474                     # that could be wrong because it could reflect a
7475                     # previous release
7476                     undef $req;
7477                 }
7478             }
7479             my $areq;
7480             my $do_replace;
7481             while (my($k,$v) = each %{$req||{}}) {
7482                 if ($v =~ /\d/) {
7483                     $areq->{$k} = $v;
7484                 } elsif ($k =~ /[A-Za-z]/ &&
7485                          $v =~ /[A-Za-z]/ &&
7486                          $CPAN::META->exists("Module",$v)
7487                         ) {
7488                     $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
7489                                             "requires hash: $k => $v; I'll take both ".
7490                                             "key and value as a module name\n");
7491                     $CPAN::Frontend->mysleep(1);
7492                     $areq->{$k} = 0;
7493                     $areq->{$v} = 0;
7494                     $do_replace++;
7495                 }
7496             }
7497             $req = $areq if $do_replace;
7498         }
7499     }
7500     unless ($req || $breq) {
7501         my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
7502         my $makefile = File::Spec->catfile($build_dir,"Makefile");
7503         my $fh;
7504         if (-f $makefile
7505             and
7506             $fh = FileHandle->new("<$makefile\0")) {
7507             CPAN->debug("Getting prereq from Makefile") if $CPAN::DEBUG;
7508             local($/) = "\n";
7509             while (<$fh>) {
7510                 last if /MakeMaker post_initialize section/;
7511                 my($p) = m{^[\#]
7512                            \s+PREREQ_PM\s+=>\s+(.+)
7513                        }x;
7514                 next unless $p;
7515                 # warn "Found prereq expr[$p]";
7516
7517                 #  Regexp modified by A.Speer to remember actual version of file
7518                 #  PREREQ_PM hash key wants, then add to
7519                 while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
7520                     # In case a prereq is mentioned twice, complain.
7521                     if ( defined $req->{$1} ) {
7522                         warn "Warning: PREREQ_PM mentions $1 more than once, ".
7523                             "last mention wins";
7524                     }
7525                     $req->{$1} = $2;
7526                 }
7527                 last;
7528             }
7529         }
7530     }
7531     unless ($req || $breq) {
7532         my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
7533         my $buildfile = File::Spec->catfile($build_dir,"Build");
7534         if (-f $buildfile) {
7535             CPAN->debug("Found '$buildfile'") if $CPAN::DEBUG;
7536             my $build_prereqs = File::Spec->catfile($build_dir,"_build","prereqs");
7537             if (-f $build_prereqs) {
7538                 CPAN->debug("Getting prerequisites from '$build_prereqs'") if $CPAN::DEBUG;
7539                 my $content = do { local *FH;
7540                                    open FH, $build_prereqs
7541                                        or $CPAN::Frontend->mydie("Could not open ".
7542                                                                  "'$build_prereqs': $!");
7543                                    local $/;
7544                                    <FH>;
7545                                };
7546                 my $bphash = eval $content;
7547                 if ($@) {
7548                 } else {
7549                     $req  = $bphash->{requires} || +{};
7550                     $breq = $bphash->{build_requires} || +{};
7551                 }
7552             }
7553         }
7554     }
7555     if (-f "Build.PL"
7556         && ! -f "Makefile.PL"
7557         && ! exists $req->{"Module::Build"}
7558         && ! $CPAN::META->has_inst("Module::Build")) {
7559         $CPAN::Frontend->mywarn("  Warning: CPAN.pm discovered Module::Build as ".
7560                                 "undeclared prerequisite.\n".
7561                                 "  Adding it now as such.\n"
7562                                );
7563         $CPAN::Frontend->mysleep(5);
7564         $req->{"Module::Build"} = 0;
7565         delete $self->{writemakefile};
7566     }
7567     if ($req || $breq) {
7568         $self->{prereq_pm_detected}++;
7569         return $self->{prereq_pm} = { requires => $req, build_requires => $breq };
7570     }
7571 }
7572
7573 #-> sub CPAN::Distribution::test ;
7574 sub test {
7575     my($self) = @_;
7576     if (my $goto = $self->prefs->{goto}) {
7577         return $self->goto($goto);
7578     }
7579     $self->make;
7580     if ($CPAN::Signal){
7581       delete $self->{force_update};
7582       return;
7583     }
7584     # warn "XDEBUG: checking for notest: $self->{notest} $self";
7585     if ($self->{notest}) {
7586         $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
7587         return 1;
7588     }
7589
7590     my $make = $self->{modulebuild} ? "Build" : "make";
7591
7592     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
7593                            ? $ENV{PERL5LIB}
7594                            : ($ENV{PERLLIB} || "");
7595
7596     $CPAN::META->set_perl5lib;
7597     local $ENV{MAKEFLAGS}; # protect us from outer make calls
7598
7599     $CPAN::Frontend->myprint("Running $make test\n");
7600     if (my @prereq = $self->unsat_prereq){
7601         unless ($prereq[0][0] eq "perl") {
7602             return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
7603         }
7604     }
7605   EXCUSE: {
7606         my @e;
7607         unless (exists $self->{make} or exists $self->{later}) {
7608             push @e,
7609                 "Make had some problems, won't test";
7610         }
7611
7612         exists $self->{make} and
7613             (
7614              UNIVERSAL::can($self->{make},"failed") ?
7615              $self->{make}->failed :
7616              $self->{make} =~ /^NO/
7617             ) and push @e, "Can't test without successful make";
7618
7619         $self->{badtestcnt} ||= 0;
7620         $self->{badtestcnt} > 0 and
7621             push @e, "Won't repeat unsuccessful test during this command";
7622
7623         exists $self->{later} and length($self->{later}) and
7624             push @e, $self->{later};
7625
7626         if (exists $self->{build_dir}) {
7627             if ($CPAN::META->{is_tested}{$self->{build_dir}}
7628                 &&
7629                 exists $self->{make_test}
7630                 &&
7631                 !(
7632                   UNIVERSAL::can($self->{make_test},"failed") ?
7633                   $self->{make_test}->failed :
7634                   $self->{make_test} =~ /^NO/
7635                  )
7636                ) {
7637                 push @e, "Has already been tested successfully";
7638             }
7639         } elsif (!@e) {
7640             push @e, "Has no own directory";
7641         }
7642         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
7643         unless (chdir $self->{build_dir}) {
7644             push @e, "Couldn't chdir to '$self->{build_dir}': $!";
7645         }
7646         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
7647     }
7648     $self->debug("Changed directory to $self->{build_dir}")
7649         if $CPAN::DEBUG;
7650
7651     if ($^O eq 'MacOS') {
7652         Mac::BuildTools::make_test($self);
7653         return;
7654     }
7655
7656     if ($self->{modulebuild}) {
7657         my $v = CPAN::Shell->expand("Module","Test::Harness")->inst_version;
7658         if (CPAN::Version->vlt($v,2.62)) {
7659             $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
7660   '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n});
7661             $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old");
7662             return;
7663         }
7664     }
7665
7666     my $system;
7667     if (my $commandline = $self->prefs->{test}{commandline}) {
7668         $system = $commandline;
7669         $ENV{PERL} = $^X;
7670     } elsif ($self->{modulebuild}) {
7671         $system = sprintf "%s test", $self->_build_command();
7672     } else {
7673         $system = join " ", $self->_make_command(), "test";
7674     }
7675     my($tests_ok);
7676     my %env;
7677     while (my($k,$v) = each %ENV) {
7678         next unless defined $v;
7679         $env{$k} = $v;
7680     }
7681     local %ENV = %env;
7682     if (my $env = $self->prefs->{test}{env}) {
7683         for my $e (keys %$env) {
7684             $ENV{$e} = $env->{$e};
7685         }
7686     }
7687     my $expect_model = $self->_prefs_with_expect("test");
7688     my $want_expect = 0;
7689     if ( $expect_model && @{$expect_model->{talk}} ) {
7690         my $can_expect = $CPAN::META->has_inst("Expect");
7691         if ($can_expect) {
7692             $want_expect = 1;
7693         } else {
7694             $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
7695                                     "testing without\n");
7696         }
7697     }
7698     my $test_report = CPAN::HandleConfig->prefs_lookup($self,
7699                                                        q{test_report});
7700     my $want_report;
7701     if ($test_report) {
7702         my $can_report = $CPAN::META->has_inst("CPAN::Reporter");
7703         if ($can_report) {
7704             $want_report = 1;
7705         } else {
7706             $CPAN::Frontend->mywarn("CPAN::Reporter not installed, falling back to ".
7707                                     "testing without\n");
7708         }
7709     }
7710     my $ready_to_report = $want_report;
7711     if ($ready_to_report
7712         && (
7713             substr($self->id,-1,1) eq "."
7714             ||
7715             $self->author->id eq "LOCAL"
7716            )
7717        ) {
7718         $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
7719                                 "for local directories\n");
7720         $ready_to_report = 0;
7721     }
7722     if ($ready_to_report
7723         &&
7724         $self->prefs->{patches}
7725         &&
7726         @{$self->prefs->{patches}}
7727         &&
7728         $self->{patched}
7729        ) {
7730         $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
7731                                 "when the source has been patched\n");
7732         $ready_to_report = 0;
7733     }
7734     if ($want_expect) {
7735         if ($ready_to_report) {
7736             $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ".
7737                                     "not supported when distroprefs specify ".
7738                                     "an interactive test\n");
7739         }
7740         $tests_ok = $self->_run_via_expect($system,$expect_model) == 0;
7741     } elsif ( $ready_to_report ) {
7742         $tests_ok = CPAN::Reporter::test($self, $system);
7743     } else {
7744         $tests_ok = system($system) == 0;
7745     }
7746     $self->introduce_myself;
7747     if ( $tests_ok ) {
7748         {
7749             my @prereq;
7750
7751             # local $CPAN::DEBUG = 16; # Distribution
7752             for my $m (keys %{$self->{sponsored_mods}}) {
7753                 my $m_obj = CPAN::Shell->expand("Module",$m);
7754                 # XXX we need available_version which reflects
7755                 # $ENV{PERL5LIB} so that already tested but not yet
7756                 # installed modules are counted.
7757                 my $available_version = $m_obj->available_version;
7758                 my $available_file = $m_obj->available_file;
7759                 if ($available_version &&
7760                     !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m})
7761                    ) {
7762                     CPAN->debug("m[$m] good enough available_version[$available_version]")
7763                         if $CPAN::DEBUG;
7764                 } elsif ($available_file
7765                          && (
7766                              !$self->{prereq_pm}{$m}
7767                              ||
7768                              $self->{prereq_pm}{$m} == 0
7769                             )
7770                         ) {
7771                     # lex Class::Accessor::Chained::Fast which has no $VERSION
7772                     CPAN->debug("m[$m] have available_file[$available_file]")
7773                         if $CPAN::DEBUG;
7774                 } else {
7775                     push @prereq, $m;
7776                 }
7777             }
7778             if (@prereq){
7779                 my $cnt = @prereq;
7780                 my $which = join ",", @prereq;
7781                 my $but = $cnt == 1 ? "one dependency not OK ($which)" :
7782                     "$cnt dependencies missing ($which)";
7783                 $CPAN::Frontend->mywarn("Tests succeeded but $but\n");
7784                 $self->{make_test} = CPAN::Distrostatus->new("NO $but");
7785                 $self->store_persistent_state;
7786                 return;
7787             }
7788         }
7789
7790         $CPAN::Frontend->myprint("  $system -- OK\n");
7791         $self->{make_test} = CPAN::Distrostatus->new("YES");
7792         $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
7793         # probably impossible to need the next line because badtestcnt
7794         # has a lifespan of one command
7795         delete $self->{badtestcnt};
7796     } else {
7797         $self->{make_test} = CPAN::Distrostatus->new("NO");
7798         $self->{badtestcnt}++;
7799         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
7800     }
7801     $self->store_persistent_state;
7802 }
7803
7804 sub _prefs_with_expect {
7805     my($self,$where) = @_;
7806     return unless my $prefs = $self->prefs;
7807     return unless my $where_prefs = $prefs->{$where};
7808     if ($where_prefs->{expect}) {
7809         return {
7810                 mode => "deterministic",
7811                 timeout => 15,
7812                 talk => $where_prefs->{expect},
7813                };
7814     } elsif ($where_prefs->{"eexpect"}) {
7815         return $where_prefs->{"eexpect"};
7816     }
7817     return;
7818 }
7819
7820 #-> sub CPAN::Distribution::clean ;
7821 sub clean {
7822     my($self) = @_;
7823     my $make = $self->{modulebuild} ? "Build" : "make";
7824     $CPAN::Frontend->myprint("Running $make clean\n");
7825     unless (exists $self->{archived}) {
7826         $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped".
7827                                 "/untarred, nothing done\n");
7828         return 1;
7829     }
7830     unless (exists $self->{build_dir}) {
7831         $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
7832         return 1;
7833     }
7834   EXCUSE: {
7835         my @e;
7836         exists $self->{make_clean} and $self->{make_clean} eq "YES" and
7837             push @e, "make clean already called once";
7838         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
7839     }
7840     chdir $self->{build_dir} or
7841         Carp::confess("Couldn't chdir to $self->{build_dir}: $!");
7842     $self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG;
7843
7844     if ($^O eq 'MacOS') {
7845         Mac::BuildTools::make_clean($self);
7846         return;
7847     }
7848
7849     my $system;
7850     if ($self->{modulebuild}) {
7851         unless (-f "Build") {
7852             my $cwd = CPAN::anycwd();
7853             $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
7854                                     " in cwd[$cwd]. Danger, Will Robinson!");
7855             $CPAN::Frontend->mysleep(5);
7856         }
7857         $system = sprintf "%s clean", $self->_build_command();
7858     } else {
7859         $system  = join " ", $self->_make_command(), "clean";
7860     }
7861     my $system_ok = system($system) == 0;
7862     $self->introduce_myself;
7863     if ( $system_ok ) {
7864       $CPAN::Frontend->myprint("  $system -- OK\n");
7865
7866       # $self->force;
7867
7868       # Jost Krieger pointed out that this "force" was wrong because
7869       # it has the effect that the next "install" on this distribution
7870       # will untar everything again. Instead we should bring the
7871       # object's state back to where it is after untarring.
7872
7873       for my $k (qw(
7874                     force_update
7875                     install
7876                     writemakefile
7877                     make
7878                     make_test
7879                    )) {
7880           delete $self->{$k};
7881       }
7882       $self->{make_clean} = CPAN::Distrostatus->new("YES");
7883
7884     } else {
7885       # Hmmm, what to do if make clean failed?
7886
7887       $self->{make_clean} = CPAN::Distrostatus->new("NO");
7888       $CPAN::Frontend->mywarn(qq{  $system -- NOT OK\n});
7889
7890       # 2006-02-27: seems silly to me to force a make now
7891       # $self->force("make"); # so that this directory won't be used again
7892
7893     }
7894     $self->store_persistent_state;
7895 }
7896
7897 #-> sub CPAN::Distribution::goto ;
7898 sub goto {
7899     my($self,$goto) = @_;
7900     $goto = $self->normalize($goto);
7901
7902     # inject into the queue
7903
7904     CPAN::Queue->delete($self->id);
7905     CPAN::Queue->jumpqueue([$goto,$self->{reqtype}]);
7906
7907     # and run where we left off
7908
7909     my($method) = (caller(1))[3];
7910     CPAN->instance("CPAN::Distribution",$goto)->$method;
7911     CPAN::Queue->delete_first($goto);
7912 }
7913
7914 #-> sub CPAN::Distribution::install ;
7915 sub install {
7916     my($self) = @_;
7917     if (my $goto = $self->prefs->{goto}) {
7918         return $self->goto($goto);
7919     }
7920     $self->test;
7921     if ($CPAN::Signal){
7922       delete $self->{force_update};
7923       return;
7924     }
7925     my $make = $self->{modulebuild} ? "Build" : "make";
7926     $CPAN::Frontend->myprint("Running $make install\n");
7927   EXCUSE: {
7928         my @e;
7929         unless (exists $self->{make} or exists $self->{later}) {
7930             push @e,
7931                 "Make had some problems, won't install";
7932         }
7933
7934         exists $self->{make} and
7935             (
7936              UNIVERSAL::can($self->{make},"failed") ?
7937              $self->{make}->failed :
7938              $self->{make} =~ /^NO/
7939             ) and
7940                 push @e, "Make had returned bad status, install seems impossible";
7941
7942         if (exists $self->{build_dir}) {
7943         } elsif (!@e) {
7944             push @e, "Has no own directory";
7945         }
7946
7947         if (exists $self->{make_test} and
7948             (
7949              UNIVERSAL::can($self->{make_test},"failed") ?
7950              $self->{make_test}->failed :
7951              $self->{make_test} =~ /^NO/
7952             )){
7953             if ($self->{force_update}) {
7954                 $self->{make_test}->text("FAILED but failure ignored because ".
7955                                          "'force' in effect");
7956             } else {
7957                 push @e, "make test had returned bad status, ".
7958                     "won't install without force"
7959             }
7960         }
7961         if (exists $self->{install}) {
7962             if (UNIVERSAL::can($self->{install},"text") ?
7963                 $self->{install}->text eq "YES" :
7964                 $self->{install} =~ /^YES/
7965                ) {
7966                 push @e, "Already done";
7967             } else {
7968                 # comment in Todo on 2006-02-11; maybe retry?
7969                 push @e, "Already tried without success";
7970             }
7971         }
7972
7973         exists $self->{later} and length($self->{later}) and
7974             push @e, $self->{later};
7975
7976         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
7977         unless (chdir $self->{build_dir}) {
7978             push @e, "Couldn't chdir to '$self->{build_dir}': $!";
7979         }
7980         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
7981     }
7982     $self->debug("Changed directory to $self->{build_dir}")
7983         if $CPAN::DEBUG;
7984
7985     if ($^O eq 'MacOS') {
7986         Mac::BuildTools::make_install($self);
7987         return;
7988     }
7989
7990     my $system;
7991     if (my $commandline = $self->prefs->{install}{commandline}) {
7992         $system = $commandline;
7993         $ENV{PERL} = $^X;
7994     } elsif ($self->{modulebuild}) {
7995         my($mbuild_install_build_command) =
7996             exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
7997                 $CPAN::Config->{mbuild_install_build_command} ?
7998                     $CPAN::Config->{mbuild_install_build_command} :
7999                         $self->_build_command();
8000         $system = sprintf("%s install %s",
8001                           $mbuild_install_build_command,
8002                           $CPAN::Config->{mbuild_install_arg},
8003                          );
8004     } else {
8005         my($make_install_make_command) =
8006             CPAN::HandleConfig->prefs_lookup($self,
8007                                              q{make_install_make_command})
8008                   || $self->_make_command();
8009         $system = sprintf("%s install %s",
8010                           $make_install_make_command,
8011                           $CPAN::Config->{make_install_arg},
8012                          );
8013     }
8014
8015     my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 ";
8016     my $brip = CPAN::HandleConfig->prefs_lookup($self,
8017                                                 q{build_requires_install_policy});
8018     $brip ||="ask/yes";
8019     my $id = $self->id;
8020     my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command
8021     my $want_install = "yes";
8022     if ($reqtype eq "b") {
8023         if ($brip eq "no") {
8024             $want_install = "no";
8025         } elsif ($brip =~ m|^ask/(.+)|) {
8026             my $default = $1;
8027             $default = "yes" unless $default =~ /^(y|n)/i;
8028             $want_install =
8029                 CPAN::Shell::colorable_makemaker_prompt
8030                       ("$id is just needed temporarily during building or testing. ".
8031                        "Do you want to install it permanently? (Y/n)",
8032                        $default);
8033         }
8034     }
8035     unless ($want_install =~ /^y/i) {
8036         my $is_only = "is only 'build_requires'";
8037         $CPAN::Frontend->mywarn("Not installing because $is_only\n");
8038         $self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
8039         delete $self->{force_update};
8040         return;
8041     }
8042     my($pipe) = FileHandle->new("$system $stderr |");
8043     my($makeout) = "";
8044     while (<$pipe>){
8045         print $_; # intentionally NOT use Frontend->myprint because it
8046                   # looks irritating when we markup in color what we
8047                   # just pass through from an external program
8048         $makeout .= $_;
8049     }
8050     $pipe->close;
8051     my $close_ok = $? == 0;
8052     $self->introduce_myself;
8053     if ( $close_ok ) {
8054         $CPAN::Frontend->myprint("  $system -- OK\n");
8055         $CPAN::META->is_installed($self->{build_dir});
8056         $self->{install} = CPAN::Distrostatus->new("YES");
8057     } else {
8058         $self->{install} = CPAN::Distrostatus->new("NO");
8059         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
8060         my $mimc =
8061             CPAN::HandleConfig->prefs_lookup($self,
8062                                              q{make_install_make_command});
8063         if (
8064             $makeout =~ /permission/s
8065             && $> > 0
8066             && (
8067                 ! $mimc
8068                 || $mimc eq (CPAN::HandleConfig->prefs_lookup($self,
8069                                                               q{make}))
8070                )
8071            ) {
8072             $CPAN::Frontend->myprint(
8073                                      qq{----\n}.
8074                                      qq{  You may have to su }.
8075                                      qq{to root to install the package\n}.
8076                                      qq{  (Or you may want to run something like\n}.
8077                                      qq{    o conf make_install_make_command 'sudo make'\n}.
8078                                      qq{  to raise your permissions.}
8079                                     );
8080         }
8081     }
8082     delete $self->{force_update};
8083     # $DB::single = 1;
8084     $self->store_persistent_state;
8085 }
8086
8087 sub introduce_myself {
8088     my($self) = @_;
8089     $CPAN::Frontend->myprint(sprintf("  %s\n",$self->pretty_id));
8090 }
8091
8092 #-> sub CPAN::Distribution::dir ;
8093 sub dir {
8094     shift->{build_dir};
8095 }
8096
8097 #-> sub CPAN::Distribution::perldoc ;
8098 sub perldoc {
8099     my($self) = @_;
8100
8101     my($dist) = $self->id;
8102     my $package = $self->called_for;
8103
8104     $self->_display_url( $CPAN::Defaultdocs . $package );
8105 }
8106
8107 #-> sub CPAN::Distribution::_check_binary ;
8108 sub _check_binary {
8109     my ($dist,$shell,$binary) = @_;
8110     my ($pid,$out);
8111
8112     $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
8113       if $CPAN::DEBUG;
8114
8115     if ($CPAN::META->has_inst("File::Which")) {
8116         return File::Which::which($binary);
8117     } else {
8118         local *README;
8119         $pid = open README, "which $binary|"
8120             or $CPAN::Frontend->mywarn(qq{Could not fork 'which $binary': $!\n});
8121         return unless $pid;
8122         while (<README>) {
8123             $out .= $_;
8124         }
8125         close README
8126             or $CPAN::Frontend->mywarn("Could not run 'which $binary': $!\n")
8127                 and return;
8128     }
8129
8130     $CPAN::Frontend->myprint(qq{   + $out \n})
8131       if $CPAN::DEBUG && $out;
8132
8133     return $out;
8134 }
8135
8136 #-> sub CPAN::Distribution::_display_url ;
8137 sub _display_url {
8138     my($self,$url) = @_;
8139     my($res,$saved_file,$pid,$out);
8140
8141     $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
8142       if $CPAN::DEBUG;
8143
8144     # should we define it in the config instead?
8145     my $html_converter = "html2text";
8146
8147     my $web_browser = $CPAN::Config->{'lynx'} || undef;
8148     my $web_browser_out = $web_browser
8149       ? CPAN::Distribution->_check_binary($self,$web_browser)
8150         : undef;
8151
8152     if ($web_browser_out) {
8153         # web browser found, run the action
8154         my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
8155         $CPAN::Frontend->myprint(qq{system[$browser $url]})
8156           if $CPAN::DEBUG;
8157         $CPAN::Frontend->myprint(qq{
8158 Displaying URL
8159   $url
8160 with browser $browser
8161 });
8162         $CPAN::Frontend->mysleep(1);
8163         system("$browser $url");
8164         if ($saved_file) { 1 while unlink($saved_file) }
8165     } else {
8166         # web browser not found, let's try text only
8167         my $html_converter_out =
8168           CPAN::Distribution->_check_binary($self,$html_converter);
8169         $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out);
8170
8171         if ($html_converter_out ) {
8172             # html2text found, run it
8173             $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
8174             $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n})
8175                 unless defined($saved_file);
8176
8177             local *README;
8178             $pid = open README, "$html_converter $saved_file |"
8179               or $CPAN::Frontend->mydie(qq{
8180 Could not fork '$html_converter $saved_file': $!});
8181             my($fh,$filename);
8182             if ($CPAN::META->has_inst("File::Temp")) {
8183                 $fh = File::Temp->new(
8184                                       template => 'cpan_htmlconvert_XXXX',
8185                                       suffix => '.txt',
8186                                       unlink => 0,
8187                                      );
8188                 $filename = $fh->filename;
8189             } else {
8190                 $filename = "cpan_htmlconvert_$$.txt";
8191                 $fh = FileHandle->new();
8192                 open $fh, ">$filename" or die;
8193             }
8194             while (<README>) {
8195                 $fh->print($_);
8196             }
8197             close README or
8198                 $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
8199             my $tmpin = $fh->filename;
8200             $CPAN::Frontend->myprint(sprintf(qq{
8201 Run '%s %s' and
8202 saved output to %s\n},
8203                                              $html_converter,
8204                                              $saved_file,
8205                                              $tmpin,
8206                                             )) if $CPAN::DEBUG;
8207             close $fh;
8208             local *FH;
8209             open FH, $tmpin
8210                 or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
8211             my $fh_pager = FileHandle->new;
8212             local($SIG{PIPE}) = "IGNORE";
8213             my $pager = $CPAN::Config->{'pager'} || "cat";
8214             $fh_pager->open("|$pager")
8215                 or $CPAN::Frontend->mydie(qq{
8216 Could not open pager '$pager': $!});
8217             $CPAN::Frontend->myprint(qq{
8218 Displaying URL
8219   $url
8220 with pager "$pager"
8221 });
8222             $CPAN::Frontend->mysleep(1);
8223             $fh_pager->print(<FH>);
8224             $fh_pager->close;
8225         } else {
8226             # coldn't find the web browser or html converter
8227             $CPAN::Frontend->myprint(qq{
8228 You need to install lynx or $html_converter to use this feature.});
8229         }
8230     }
8231 }
8232
8233 #-> sub CPAN::Distribution::_getsave_url ;
8234 sub _getsave_url {
8235     my($dist, $shell, $url) = @_;
8236
8237     $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
8238       if $CPAN::DEBUG;
8239
8240     my($fh,$filename);
8241     if ($CPAN::META->has_inst("File::Temp")) {
8242         $fh = File::Temp->new(
8243                               template => "cpan_getsave_url_XXXX",
8244                               suffix => ".html",
8245                               unlink => 0,
8246                              );
8247         $filename = $fh->filename;
8248     } else {
8249         $fh = FileHandle->new;
8250         $filename = "cpan_getsave_url_$$.html";
8251     }
8252     my $tmpin = $filename;
8253     if ($CPAN::META->has_usable('LWP')) {
8254         $CPAN::Frontend->myprint("Fetching with LWP:
8255   $url
8256 ");
8257         my $Ua;
8258         CPAN::LWP::UserAgent->config;
8259         eval { $Ua = CPAN::LWP::UserAgent->new; };
8260         if ($@) {
8261             $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
8262             return;
8263         } else {
8264             my($var);
8265             $Ua->proxy('http', $var)
8266                 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
8267             $Ua->no_proxy($var)
8268                 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
8269         }
8270
8271         my $req = HTTP::Request->new(GET => $url);
8272         $req->header('Accept' => 'text/html');
8273         my $res = $Ua->request($req);
8274         if ($res->is_success) {
8275             $CPAN::Frontend->myprint(" + request successful.\n")
8276                 if $CPAN::DEBUG;
8277             print $fh $res->content;
8278             close $fh;
8279             $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
8280                 if $CPAN::DEBUG;
8281             return $tmpin;
8282         } else {
8283             $CPAN::Frontend->myprint(sprintf(
8284                                              "LWP failed with code[%s], message[%s]\n",
8285                                              $res->code,
8286                                              $res->message,
8287                                             ));
8288             return;
8289         }
8290     } else {
8291         $CPAN::Frontend->mywarn("  LWP not available\n");
8292         return;
8293     }
8294 }
8295
8296 # sub CPAN::Distribution::_build_command
8297 sub _build_command {
8298     my($self) = @_;
8299     if ($^O eq "MSWin32") { # special code needed at least up to
8300                             # Module::Build 0.2611 and 0.2706; a fix
8301                             # in M:B has been promised 2006-01-30
8302         my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
8303         return "$perl ./Build";
8304     }
8305     return "./Build";
8306 }
8307
8308 package CPAN::Bundle;
8309 use strict;
8310
8311 sub look {
8312     my $self = shift;
8313     $CPAN::Frontend->myprint($self->as_string);
8314 }
8315
8316 sub undelay {
8317     my $self = shift;
8318     delete $self->{later};
8319     for my $c ( $self->contains ) {
8320         my $obj = CPAN::Shell->expandany($c) or next;
8321         $obj->undelay;
8322     }
8323 }
8324
8325 # mark as dirty/clean
8326 #-> sub CPAN::Bundle::color_cmd_tmps ;
8327 sub color_cmd_tmps {
8328     my($self) = shift;
8329     my($depth) = shift || 0;
8330     my($color) = shift || 0;
8331     my($ancestors) = shift || [];
8332     # a module needs to recurse to its cpan_file, a distribution needs
8333     # to recurse into its prereq_pms, a bundle needs to recurse into its modules
8334
8335     return if exists $self->{incommandcolor}
8336         && $self->{incommandcolor}==$color;
8337     if ($depth>=100){
8338         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
8339     }
8340     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
8341
8342     for my $c ( $self->contains ) {
8343         my $obj = CPAN::Shell->expandany($c) or next;
8344         CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
8345         $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
8346     }
8347     # never reached code?
8348     #if ($color==0) {
8349       #delete $self->{badtestcnt};
8350     #}
8351     $self->{incommandcolor} = $color;
8352 }
8353
8354 #-> sub CPAN::Bundle::as_string ;
8355 sub as_string {
8356     my($self) = @_;
8357     $self->contains;
8358     # following line must be "=", not "||=" because we have a moving target
8359     $self->{INST_VERSION} = $self->inst_version;
8360     return $self->SUPER::as_string;
8361 }
8362
8363 #-> sub CPAN::Bundle::contains ;
8364 sub contains {
8365     my($self) = @_;
8366     my($inst_file) = $self->inst_file || "";
8367     my($id) = $self->id;
8368     $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
8369     if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) {
8370         undef $inst_file;
8371     }
8372     unless ($inst_file) {
8373         # Try to get at it in the cpan directory
8374         $self->debug("no inst_file") if $CPAN::DEBUG;
8375         my $cpan_file;
8376         $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
8377               $cpan_file = $self->cpan_file;
8378         if ($cpan_file eq "N/A") {
8379             $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
8380   Maybe stale symlink? Maybe removed during session? Giving up.\n");
8381         }
8382         my $dist = $CPAN::META->instance('CPAN::Distribution',
8383                                          $self->cpan_file);
8384         $self->debug("before get id[$dist->{ID}]") if $CPAN::DEBUG;
8385         $dist->get;
8386         $self->debug("after get id[$dist->{ID}]") if $CPAN::DEBUG;
8387         my($todir) = $CPAN::Config->{'cpan_home'};
8388         my(@me,$from,$to,$me);
8389         @me = split /::/, $self->id;
8390         $me[-1] .= ".pm";
8391         $me = File::Spec->catfile(@me);
8392         $from = $self->find_bundle_file($dist->{build_dir},join('/',@me));
8393         $to = File::Spec->catfile($todir,$me);
8394         File::Path::mkpath(File::Basename::dirname($to));
8395         File::Copy::copy($from, $to)
8396               or Carp::confess("Couldn't copy $from to $to: $!");
8397         $inst_file = $to;
8398     }
8399     my @result;
8400     my $fh = FileHandle->new;
8401     local $/ = "\n";
8402     open($fh,$inst_file) or die "Could not open '$inst_file': $!";
8403     my $in_cont = 0;
8404     $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
8405     while (<$fh>) {
8406         $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
8407             m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
8408         next unless $in_cont;
8409         next if /^=/;
8410         s/\#.*//;
8411         next if /^\s+$/;
8412         chomp;
8413         push @result, (split " ", $_, 2)[0];
8414     }
8415     close $fh;
8416     delete $self->{STATUS};
8417     $self->{CONTAINS} = \@result;
8418     $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
8419     unless (@result) {
8420         $CPAN::Frontend->mywarn(qq{
8421 The bundle file "$inst_file" may be a broken
8422 bundlefile. It seems not to contain any bundle definition.
8423 Please check the file and if it is bogus, please delete it.
8424 Sorry for the inconvenience.
8425 });
8426     }
8427     @result;
8428 }
8429
8430 #-> sub CPAN::Bundle::find_bundle_file
8431 # $where is in local format, $what is in unix format
8432 sub find_bundle_file {
8433     my($self,$where,$what) = @_;
8434     $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
8435 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
8436 ###    my $bu = File::Spec->catfile($where,$what);
8437 ###    return $bu if -f $bu;
8438     my $manifest = File::Spec->catfile($where,"MANIFEST");
8439     unless (-f $manifest) {
8440         require ExtUtils::Manifest;
8441         my $cwd = CPAN::anycwd();
8442         $self->safe_chdir($where);
8443         ExtUtils::Manifest::mkmanifest();
8444         $self->safe_chdir($cwd);
8445     }
8446     my $fh = FileHandle->new($manifest)
8447         or Carp::croak("Couldn't open $manifest: $!");
8448     local($/) = "\n";
8449     my $bundle_filename = $what;
8450     $bundle_filename =~ s|Bundle.*/||;
8451     my $bundle_unixpath;
8452     while (<$fh>) {
8453         next if /^\s*\#/;
8454         my($file) = /(\S+)/;
8455         if ($file =~ m|\Q$what\E$|) {
8456             $bundle_unixpath = $file;
8457             # return File::Spec->catfile($where,$bundle_unixpath); # bad
8458             last;
8459         }
8460         # retry if she managed to have no Bundle directory
8461         $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
8462     }
8463     return File::Spec->catfile($where, split /\//, $bundle_unixpath)
8464         if $bundle_unixpath;
8465     Carp::croak("Couldn't find a Bundle file in $where");
8466 }
8467
8468 # needs to work quite differently from Module::inst_file because of
8469 # cpan_home/Bundle/ directory and the possibility that we have
8470 # shadowing effect. As it makes no sense to take the first in @INC for
8471 # Bundles, we parse them all for $VERSION and take the newest.
8472
8473 #-> sub CPAN::Bundle::inst_file ;
8474 sub inst_file {
8475     my($self) = @_;
8476     my($inst_file);
8477     my(@me);
8478     @me = split /::/, $self->id;
8479     $me[-1] .= ".pm";
8480     my($incdir,$bestv);
8481     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
8482         my $bfile = File::Spec->catfile($incdir, @me);
8483         CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
8484         next unless -f $bfile;
8485         my $foundv = MM->parse_version($bfile);
8486         if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
8487             $self->{INST_FILE} = $bfile;
8488             $self->{INST_VERSION} = $bestv = $foundv;
8489         }
8490     }
8491     $self->{INST_FILE};
8492 }
8493
8494 #-> sub CPAN::Bundle::inst_version ;
8495 sub inst_version {
8496     my($self) = @_;
8497     $self->inst_file; # finds INST_VERSION as side effect
8498     $self->{INST_VERSION};
8499 }
8500
8501 #-> sub CPAN::Bundle::rematein ;
8502 sub rematein {
8503     my($self,$meth) = @_;
8504     $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
8505     my($id) = $self->id;
8506     Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
8507         unless $self->inst_file || $self->cpan_file;
8508     my($s,%fail);
8509     for $s ($self->contains) {
8510         my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
8511             $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
8512         if ($type eq 'CPAN::Distribution') {
8513             $CPAN::Frontend->mywarn(qq{
8514 The Bundle }.$self->id.qq{ contains
8515 explicitly a file '$s'.
8516 Going to $meth that.
8517 });
8518             $CPAN::Frontend->mysleep(5);
8519         }
8520         # possibly noisy action:
8521         $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
8522         my $obj = $CPAN::META->instance($type,$s);
8523         $obj->{reqtype} = $self->{reqtype};
8524         $obj->$meth();
8525         if ($obj->isa('CPAN::Bundle')
8526             &&
8527             exists $obj->{install_failed}
8528             &&
8529             ref($obj->{install_failed}) eq "HASH"
8530            ) {
8531           for (keys %{$obj->{install_failed}}) {
8532             $self->{install_failed}{$_} = undef; # propagate faiure up
8533                                                  # to me in a
8534                                                  # recursive call
8535             $fail{$s} = 1; # the bundle itself may have succeeded but
8536                            # not all children
8537           }
8538         } else {
8539           my $success;
8540           $success = $obj->can("uptodate") ? $obj->uptodate : 0;
8541           $success ||= $obj->{install} && $obj->{install} eq "YES";
8542           if ($success) {
8543             delete $self->{install_failed}{$s};
8544           } else {
8545             $fail{$s} = 1;
8546           }
8547         }
8548     }
8549
8550     # recap with less noise
8551     if ( $meth eq "install" ) {
8552         if (%fail) {
8553             require Text::Wrap;
8554             my $raw = sprintf(qq{Bundle summary:
8555 The following items in bundle %s had installation problems:},
8556                               $self->id
8557                              );
8558             $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
8559             $CPAN::Frontend->myprint("\n");
8560             my $paragraph = "";
8561             my %reported;
8562             for $s ($self->contains) {
8563               if ($fail{$s}){
8564                 $paragraph .= "$s ";
8565                 $self->{install_failed}{$s} = undef;
8566                 $reported{$s} = undef;
8567               }
8568             }
8569             my $report_propagated;
8570             for $s (sort keys %{$self->{install_failed}}) {
8571               next if exists $reported{$s};
8572               $paragraph .= "and the following items had problems
8573 during recursive bundle calls: " unless $report_propagated++;
8574               $paragraph .= "$s ";
8575             }
8576             $CPAN::Frontend->myprint(Text::Wrap::fill("  ","  ",$paragraph));
8577             $CPAN::Frontend->myprint("\n");
8578         } else {
8579             $self->{install} = 'YES';
8580         }
8581     }
8582 }
8583
8584 # If a bundle contains another that contains an xs_file we have here,
8585 # we just don't bother I suppose
8586 #-> sub CPAN::Bundle::xs_file
8587 sub xs_file {
8588     return 0;
8589 }
8590
8591 #-> sub CPAN::Bundle::force ;
8592 sub fforce   { shift->rematein('fforce',@_); }
8593 #-> sub CPAN::Bundle::force ;
8594 sub force   { shift->rematein('force',@_); }
8595 #-> sub CPAN::Bundle::notest ;
8596 sub notest  { shift->rematein('notest',@_); }
8597 #-> sub CPAN::Bundle::get ;
8598 sub get     { shift->rematein('get',@_); }
8599 #-> sub CPAN::Bundle::make ;
8600 sub make    { shift->rematein('make',@_); }
8601 #-> sub CPAN::Bundle::test ;
8602 sub test    {
8603     my $self = shift;
8604     # $self->{badtestcnt} ||= 0;
8605     $self->rematein('test',@_);
8606 }
8607 #-> sub CPAN::Bundle::install ;
8608 sub install {
8609   my $self = shift;
8610   $self->rematein('install',@_);
8611 }
8612 #-> sub CPAN::Bundle::clean ;
8613 sub clean   { shift->rematein('clean',@_); }
8614
8615 #-> sub CPAN::Bundle::uptodate ;
8616 sub uptodate {
8617     my($self) = @_;
8618     return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
8619     my $c;
8620     foreach $c ($self->contains) {
8621         my $obj = CPAN::Shell->expandany($c);
8622         return 0 unless $obj->uptodate;
8623     }
8624     return 1;
8625 }
8626
8627 #-> sub CPAN::Bundle::readme ;
8628 sub readme  {
8629     my($self) = @_;
8630     my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
8631 No File found for bundle } . $self->id . qq{\n}), return;
8632     $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
8633     $CPAN::META->instance('CPAN::Distribution',$file)->readme;
8634 }
8635
8636 package CPAN::Module;
8637 use strict;
8638
8639 # Accessors
8640 # sub CPAN::Module::userid
8641 sub userid {
8642     my $self = shift;
8643     my $ro = $self->ro;
8644     return unless $ro;
8645     return $ro->{userid} || $ro->{CPAN_USERID};
8646 }
8647 # sub CPAN::Module::description
8648 sub description {
8649     my $self = shift;
8650     my $ro = $self->ro or return "";
8651     $ro->{description}
8652 }
8653
8654 sub distribution {
8655     my($self) = @_;
8656     CPAN::Shell->expand("Distribution",$self->cpan_file);
8657 }
8658
8659 # sub CPAN::Module::undelay
8660 sub undelay {
8661     my $self = shift;
8662     delete $self->{later};
8663     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
8664         $dist->undelay;
8665     }
8666 }
8667
8668 # mark as dirty/clean
8669 #-> sub CPAN::Module::color_cmd_tmps ;
8670 sub color_cmd_tmps {
8671     my($self) = shift;
8672     my($depth) = shift || 0;
8673     my($color) = shift || 0;
8674     my($ancestors) = shift || [];
8675     # a module needs to recurse to its cpan_file
8676
8677     return if exists $self->{incommandcolor}
8678         && $self->{incommandcolor}==$color;
8679     return if $depth>=1 && $self->uptodate;
8680     if ($depth>=100){
8681         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
8682     }
8683     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
8684
8685     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
8686         $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
8687     }
8688     # unreached code?
8689     # if ($color==0) {
8690     #    delete $self->{badtestcnt};
8691     # }
8692     $self->{incommandcolor} = $color;
8693 }
8694
8695 #-> sub CPAN::Module::as_glimpse ;
8696 sub as_glimpse {
8697     my($self) = @_;
8698     my(@m);
8699     my $class = ref($self);
8700     $class =~ s/^CPAN:://;
8701     my $color_on = "";
8702     my $color_off = "";
8703     if (
8704         $CPAN::Shell::COLOR_REGISTERED
8705         &&
8706         $CPAN::META->has_inst("Term::ANSIColor")
8707         &&
8708         $self->description
8709        ) {
8710         $color_on = Term::ANSIColor::color("green");
8711         $color_off = Term::ANSIColor::color("reset");
8712     }
8713     my $uptodateness = " ";
8714     if ($class eq "Bundle") {
8715     } elsif ($self->uptodate) {
8716         $uptodateness = "=";
8717     } elsif ($self->inst_version) {
8718         $uptodateness = "<";
8719     }
8720     push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n",
8721                      $class,
8722                      $uptodateness,
8723                      $color_on,
8724                      $self->id,
8725                      $color_off,
8726                      ($self->distribution ?
8727                       $self->distribution->pretty_id :
8728                       $self->cpan_userid
8729                      ),
8730                     );
8731     join "", @m;
8732 }
8733
8734 #-> sub CPAN::Module::dslip_status
8735 sub dslip_status {
8736     my($self) = @_;
8737     my($stat);
8738     @{$stat->{D}}{qw,i c a b R M S,}     = qw,idea
8739                                               pre-alpha alpha beta released
8740                                               mature standard,;
8741     @{$stat->{S}}{qw,m d u n a,}         = qw,mailing-list
8742                                               developer comp.lang.perl.*
8743                                               none abandoned,;
8744     @{$stat->{L}}{qw,p c + o h,}         = qw,perl C C++ other hybrid,;
8745     @{$stat->{I}}{qw,f r O p h n,}       = qw,functions
8746                                               references+ties
8747                                               object-oriented pragma
8748                                               hybrid none,;
8749     @{$stat->{P}}{qw,p g l b a o d r n,} = qw,Standard-Perl
8750                                               GPL LGPL
8751                                               BSD Artistic
8752                                               open-source
8753                                               distribution_allowed
8754                                               restricted_distribution
8755                                               no_licence,;
8756     for my $x (qw(d s l i p)) {
8757         $stat->{$x}{' '} = 'unknown';
8758         $stat->{$x}{'?'} = 'unknown';
8759     }
8760     my $ro = $self->ro;
8761     return +{} unless $ro && $ro->{statd};
8762     return {
8763             D  => $ro->{statd},
8764             S  => $ro->{stats},
8765             L  => $ro->{statl},
8766             I  => $ro->{stati},
8767             P  => $ro->{statp},
8768             DV => $stat->{D}{$ro->{statd}},
8769             SV => $stat->{S}{$ro->{stats}},
8770             LV => $stat->{L}{$ro->{statl}},
8771             IV => $stat->{I}{$ro->{stati}},
8772             PV => $stat->{P}{$ro->{statp}},
8773            };
8774 }
8775
8776 #-> sub CPAN::Module::as_string ;
8777 sub as_string {
8778     my($self) = @_;
8779     my(@m);
8780     CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
8781     my $class = ref($self);
8782     $class =~ s/^CPAN:://;
8783     local($^W) = 0;
8784     push @m, $class, " id = $self->{ID}\n";
8785     my $sprintf = "    %-12s %s\n";
8786     push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
8787         if $self->description;
8788     my $sprintf2 = "    %-12s %s (%s)\n";
8789     my($userid);
8790     $userid = $self->userid;
8791     if ( $userid ){
8792         my $author;
8793         if ($author = CPAN::Shell->expand('Author',$userid)) {
8794           my $email = "";
8795           my $m; # old perls
8796           if ($m = $author->email) {
8797             $email = " <$m>";
8798           }
8799           push @m, sprintf(
8800                            $sprintf2,
8801                            'CPAN_USERID',
8802                            $userid,
8803                            $author->fullname . $email
8804                           );
8805         }
8806     }
8807     push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
8808         if $self->cpan_version;
8809     if (my $cpan_file = $self->cpan_file){
8810         push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
8811         if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
8812             my $upload_date = $dist->upload_date;
8813             if ($upload_date) {
8814                 push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
8815             }
8816         }
8817     }
8818     my $sprintf3 = "    %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n";
8819     my $dslip = $self->dslip_status;
8820     push @m, sprintf(
8821                      $sprintf3,
8822                      'DSLIP_STATUS',
8823                      @{$dslip}{qw(D S L I P DV SV LV IV PV)},
8824                     ) if $dslip->{D};
8825     my $local_file = $self->inst_file;
8826     unless ($self->{MANPAGE}) {
8827         my $manpage;
8828         if ($local_file) {
8829             $manpage = $self->manpage_headline($local_file);
8830         } else {
8831             # If we have already untarred it, we should look there
8832             my $dist = $CPAN::META->instance('CPAN::Distribution',
8833                                              $self->cpan_file);
8834             # warn "dist[$dist]";
8835             # mff=manifest file; mfh=manifest handle
8836             my($mff,$mfh);
8837             if (
8838                 $dist->{build_dir}
8839                 and
8840                 (-f  ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
8841                 and
8842                 $mfh = FileHandle->new($mff)
8843                ) {
8844                 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
8845                 my $lfre = $self->id; # local file RE
8846                 $lfre =~ s/::/./g;
8847                 $lfre .= "\\.pm\$";
8848                 my($lfl); # local file file
8849                 local $/ = "\n";
8850                 my(@mflines) = <$mfh>;
8851                 for (@mflines) {
8852                     s/^\s+//;
8853                     s/\s.*//s;
8854                 }
8855                 while (length($lfre)>5 and !$lfl) {
8856                     ($lfl) = grep /$lfre/, @mflines;
8857                     CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
8858                     $lfre =~ s/.+?\.//;
8859                 }
8860                 $lfl =~ s/\s.*//; # remove comments
8861                 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
8862                 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
8863                 # warn "lfl_abs[$lfl_abs]";
8864                 if (-f $lfl_abs) {
8865                     $manpage = $self->manpage_headline($lfl_abs);
8866                 }
8867             }
8868         }
8869         $self->{MANPAGE} = $manpage if $manpage;
8870     }
8871     my($item);
8872     for $item (qw/MANPAGE/) {
8873         push @m, sprintf($sprintf, $item, $self->{$item})
8874             if exists $self->{$item};
8875     }
8876     for $item (qw/CONTAINS/) {
8877         push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
8878             if exists $self->{$item} && @{$self->{$item}};
8879     }
8880     push @m, sprintf($sprintf, 'INST_FILE',
8881                      $local_file || "(not installed)");
8882     push @m, sprintf($sprintf, 'INST_VERSION',
8883                      $self->inst_version) if $local_file;
8884     join "", @m, "\n";
8885 }
8886
8887 sub manpage_headline {
8888   my($self,$local_file) = @_;
8889   my(@local_file) = $local_file;
8890   $local_file =~ s/\.pm(?!\n)\Z/.pod/;
8891   push @local_file, $local_file;
8892   my(@result,$locf);
8893   for $locf (@local_file) {
8894     next unless -f $locf;
8895     my $fh = FileHandle->new($locf)
8896         or $Carp::Frontend->mydie("Couldn't open $locf: $!");
8897     my $inpod = 0;
8898     local $/ = "\n";
8899     while (<$fh>) {
8900       $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
8901           m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
8902       next unless $inpod;
8903       next if /^=/;
8904       next if /^\s+$/;
8905       chomp;
8906       push @result, $_;
8907     }
8908     close $fh;
8909     last if @result;
8910   }
8911   for (@result) {
8912       s/^\s+//;
8913       s/\s+$//;
8914   }
8915   join " ", @result;
8916 }
8917
8918 #-> sub CPAN::Module::cpan_file ;
8919 # Note: also inherited by CPAN::Bundle
8920 sub cpan_file {
8921     my $self = shift;
8922     # CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
8923     unless ($self->ro) {
8924         CPAN::Index->reload;
8925     }
8926     my $ro = $self->ro;
8927     if ($ro && defined $ro->{CPAN_FILE}){
8928         return $ro->{CPAN_FILE};
8929     } else {
8930         my $userid = $self->userid;
8931         if ( $userid ) {
8932             if ($CPAN::META->exists("CPAN::Author",$userid)) {
8933                 my $author = $CPAN::META->instance("CPAN::Author",
8934                                                    $userid);
8935                 my $fullname = $author->fullname;
8936                 my $email = $author->email;
8937                 unless (defined $fullname && defined $email) {
8938                     return sprintf("Contact Author %s",
8939                                    $userid,
8940                                   );
8941                 }
8942                 return "Contact Author $fullname <$email>";
8943             } else {
8944                 return "Contact Author $userid (Email address not available)";
8945             }
8946         } else {
8947             return "N/A";
8948         }
8949     }
8950 }
8951
8952 #-> sub CPAN::Module::cpan_version ;
8953 sub cpan_version {
8954     my $self = shift;
8955
8956     my $ro = $self->ro;
8957     unless ($ro) {
8958         # Can happen with modules that are not on CPAN
8959         $ro = {};
8960     }
8961     $ro->{CPAN_VERSION} = 'undef'
8962         unless defined $ro->{CPAN_VERSION};
8963     $ro->{CPAN_VERSION};
8964 }
8965
8966 #-> sub CPAN::Module::force ;
8967 sub force {
8968     my($self) = @_;
8969     $self->{force_update} = 1;
8970 }
8971
8972 #-> sub CPAN::Module::fforce ;
8973 sub fforce {
8974     my($self) = @_;
8975     $self->{force_update} = 2;
8976 }
8977
8978 sub notest {
8979     my($self) = @_;
8980     # warn "XDEBUG: set notest for Module";
8981     $self->{'notest'}++;
8982 }
8983
8984 #-> sub CPAN::Module::rematein ;
8985 sub rematein {
8986     my($self,$meth) = @_;
8987     $CPAN::Frontend->myprint(sprintf("Running %s for module '%s'\n",
8988                                      $meth,
8989                                      $self->id));
8990     my $cpan_file = $self->cpan_file;
8991     if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
8992       $CPAN::Frontend->mywarn(sprintf qq{
8993   The module %s isn\'t available on CPAN.
8994
8995   Either the module has not yet been uploaded to CPAN, or it is
8996   temporary unavailable. Please contact the author to find out
8997   more about the status. Try 'i %s'.
8998 },
8999                               $self->id,
9000                               $self->id,
9001                              );
9002       return;
9003     }
9004     my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
9005     $pack->called_for($self->id);
9006     if (exists $self->{force_update}){
9007         if ($self->{force_update} == 2) {
9008             $pack->fforce($meth);
9009         } else {
9010             $pack->force($meth);
9011         }
9012     }
9013     $pack->notest($meth) if exists $self->{'notest'};
9014
9015     $pack->{reqtype} ||= "";
9016     CPAN->debug("dist-reqtype[$pack->{reqtype}]".
9017                 "self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG;
9018         if ($pack->{reqtype}) {
9019             if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) {
9020                 $pack->{reqtype} = $self->{reqtype};
9021                 if (
9022                     exists $pack->{install}
9023                     &&
9024                     (
9025                      UNIVERSAL::can($pack->{install},"failed") ?
9026                      $pack->{install}->failed :
9027                      $pack->{install} =~ /^NO/
9028                     )
9029                    ) {
9030                     delete $pack->{install};
9031                     $CPAN::Frontend->mywarn
9032                         ("Promoting $pack->{ID} from 'build_requires' to 'requires'");
9033                 }
9034             }
9035         } else {
9036             $pack->{reqtype} = $self->{reqtype};
9037         }
9038
9039     eval {
9040         $pack->$meth();
9041     };
9042     my $err = $@;
9043     $pack->unforce if $pack->can("unforce") && exists $self->{force_update};
9044     $pack->unnotest if $pack->can("unnotest") && exists $self->{'notest'};
9045     delete $self->{force_update};
9046     delete $self->{'notest'};
9047     if ($err) {
9048         die $err;
9049     }
9050 }
9051
9052 #-> sub CPAN::Module::perldoc ;
9053 sub perldoc { shift->rematein('perldoc') }
9054 #-> sub CPAN::Module::readme ;
9055 sub readme  { shift->rematein('readme') }
9056 #-> sub CPAN::Module::look ;
9057 sub look    { shift->rematein('look') }
9058 #-> sub CPAN::Module::cvs_import ;
9059 sub cvs_import { shift->rematein('cvs_import') }
9060 #-> sub CPAN::Module::get ;
9061 sub get     { shift->rematein('get',@_) }
9062 #-> sub CPAN::Module::make ;
9063 sub make    { shift->rematein('make') }
9064 #-> sub CPAN::Module::test ;
9065 sub test   {
9066     my $self = shift;
9067     # $self->{badtestcnt} ||= 0;
9068     $self->rematein('test',@_);
9069 }
9070 #-> sub CPAN::Module::uptodate ;
9071 sub uptodate {
9072     my($self) = @_;
9073     local($_); # protect against a bug in MakeMaker 6.17
9074     my($latest) = $self->cpan_version;
9075     $latest ||= 0;
9076     my($inst_file) = $self->inst_file;
9077     my($have) = 0;
9078     if (defined $inst_file) {
9079         $have = $self->inst_version;
9080     }
9081     local($^W)=0;
9082     if ($inst_file
9083         &&
9084         ! CPAN::Version->vgt($latest, $have)
9085        ) {
9086         CPAN->debug("returning uptodate. inst_file[$inst_file] ".
9087                     "latest[$latest] have[$have]") if $CPAN::DEBUG;
9088         return 1;
9089     }
9090     return;
9091 }
9092 #-> sub CPAN::Module::install ;
9093 sub install {
9094     my($self) = @_;
9095     my($doit) = 0;
9096     if ($self->uptodate
9097         &&
9098         not exists $self->{force_update}
9099        ) {
9100         $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
9101                                          $self->id,
9102                                          $self->inst_version,
9103                                         ));
9104     } else {
9105         $doit = 1;
9106     }
9107     my $ro = $self->ro;
9108     if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
9109         $CPAN::Frontend->mywarn(qq{
9110 \n\n\n     ***WARNING***
9111      The module $self->{ID} has no active maintainer.\n\n\n
9112 });
9113         $CPAN::Frontend->mysleep(5);
9114     }
9115     $self->rematein('install') if $doit;
9116 }
9117 #-> sub CPAN::Module::clean ;
9118 sub clean  { shift->rematein('clean') }
9119
9120 #-> sub CPAN::Module::inst_file ;
9121 sub inst_file {
9122     my($self) = @_;
9123     $self->_file_in_path([@INC]);
9124 }
9125
9126 #-> sub CPAN::Module::available_file ;
9127 sub available_file {
9128     my($self) = @_;
9129     my $sep = $Config::Config{path_sep};
9130     my $perllib = $ENV{PERL5LIB};
9131     $perllib = $ENV{PERLLIB} unless defined $perllib;
9132     my @perllib = split(/$sep/,$perllib) if defined $perllib;
9133     $self->_file_in_path([@perllib,@INC]);
9134 }
9135
9136 #-> sub CPAN::Module::file_in_path ;
9137 sub _file_in_path {
9138     my($self,$path) = @_;
9139     my($dir,@packpath);
9140     @packpath = split /::/, $self->{ID};
9141     $packpath[-1] .= ".pm";
9142     if (@packpath == 1 && $packpath[0] eq "readline.pm") {
9143         unshift @packpath, "Term", "ReadLine"; # historical reasons
9144     }
9145     foreach $dir (@$path) {
9146         my $pmfile = File::Spec->catfile($dir,@packpath);
9147         if (-f $pmfile){
9148             return $pmfile;
9149         }
9150     }
9151     return;
9152 }
9153
9154 #-> sub CPAN::Module::xs_file ;
9155 sub xs_file {
9156     my($self) = @_;
9157     my($dir,@packpath);
9158     @packpath = split /::/, $self->{ID};
9159     push @packpath, $packpath[-1];
9160     $packpath[-1] .= "." . $Config::Config{'dlext'};
9161     foreach $dir (@INC) {
9162         my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
9163         if (-f $xsfile){
9164             return $xsfile;
9165         }
9166     }
9167     return;
9168 }
9169
9170 #-> sub CPAN::Module::inst_version ;
9171 sub inst_version {
9172     my($self) = @_;
9173     my $parsefile = $self->inst_file or return;
9174     my $have = $self->parse_version($parsefile);
9175     $have;
9176 }
9177
9178 #-> sub CPAN::Module::inst_version ;
9179 sub available_version {
9180     my($self) = @_;
9181     my $parsefile = $self->available_file or return;
9182     my $have = $self->parse_version($parsefile);
9183     $have;
9184 }
9185
9186 #-> sub CPAN::Module::parse_version ;
9187 sub parse_version {
9188     my($self,$parsefile) = @_;
9189     my $have = MM->parse_version($parsefile);
9190     $have = "undef" unless defined $have && length $have;
9191     $have =~ s/^ //; # since the %vd hack these two lines here are needed
9192     $have =~ s/ $//; # trailing whitespace happens all the time
9193
9194     $have = CPAN::Version->readable($have);
9195
9196     $have =~ s/\s*//g; # stringify to float around floating point issues
9197     $have; # no stringify needed, \s* above matches always
9198 }
9199
9200 package CPAN;
9201 use strict;
9202
9203 1;
9204
9205
9206 __END__
9207
9208 =head1 NAME
9209
9210 CPAN - query, download and build perl modules from CPAN sites
9211
9212 =head1 SYNOPSIS
9213
9214 Interactive mode:
9215
9216   perl -MCPAN -e shell;
9217
9218 Batch mode:
9219
9220   use CPAN;
9221
9222   # Modules:
9223
9224   cpan> install Acme::Meta                       # in the shell
9225
9226   CPAN::Shell->install("Acme::Meta");            # in perl
9227
9228   # Distributions:
9229
9230   cpan> install NWCLARK/Acme-Meta-0.02.tar.gz    # in the shell
9231
9232   CPAN::Shell->
9233     install("NWCLARK/Acme-Meta-0.02.tar.gz");    # in perl
9234
9235   # module objects:
9236
9237   $mo = CPAN::Shell->expandany($mod);
9238   $mo = CPAN::Shell->expand("Module",$mod);      # same thing
9239
9240   # distribution objects:
9241
9242   $do = CPAN::Shell->expand("Module",$mod)->distribution;
9243   $do = CPAN::Shell->expandany($distro);         # same thing
9244   $do = CPAN::Shell->expand("Distribution",
9245                             $distro);            # same thing
9246
9247 =head1 DESCRIPTION
9248
9249 The CPAN module is designed to automate the make and install of perl
9250 modules and extensions. It includes some primitive searching
9251 capabilities and knows how to use Net::FTP or LWP (or some external
9252 download clients) to fetch the raw data from the net.
9253
9254 Distributions are fetched from one or more of the mirrored CPAN
9255 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
9256 directory.
9257
9258 The CPAN module also supports the concept of named and versioned
9259 I<bundles> of modules. Bundles simplify the handling of sets of
9260 related modules. See Bundles below.
9261
9262 The package contains a session manager and a cache manager. The
9263 session manager keeps track of what has been fetched, built and
9264 installed in the current session. The cache manager keeps track of the
9265 disk space occupied by the make processes and deletes excess space
9266 according to a simple FIFO mechanism.
9267
9268 All methods provided are accessible in a programmer style and in an
9269 interactive shell style.
9270
9271 =head2 CPAN::shell([$prompt, $command]) Starting Interactive Mode
9272
9273 The interactive mode is entered by running
9274
9275     perl -MCPAN -e shell
9276
9277 which puts you into a readline interface. If Term::ReadKey and either
9278 Term::ReadLine::Perl or Term::ReadLine::Gnu are installed it supports
9279 both history and command completion.
9280
9281 Once you are on the command line, type 'h' to get a one page help
9282 screen and the rest should be self-explanatory.
9283
9284 The function call C<shell> takes two optional arguments, one is the
9285 prompt, the second is the default initial command line (the latter
9286 only works if a real ReadLine interface module is installed).
9287
9288 The most common uses of the interactive modes are
9289
9290 =over 2
9291
9292 =item Searching for authors, bundles, distribution files and modules
9293
9294 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
9295 for each of the four categories and another, C<i> for any of the
9296 mentioned four. Each of the four entities is implemented as a class
9297 with slightly differing methods for displaying an object.
9298
9299 Arguments you pass to these commands are either strings exactly matching
9300 the identification string of an object or regular expressions that are
9301 then matched case-insensitively against various attributes of the
9302 objects. The parser recognizes a regular expression only if you
9303 enclose it between two slashes.
9304
9305 The principle is that the number of found objects influences how an
9306 item is displayed. If the search finds one item, the result is
9307 displayed with the rather verbose method C<as_string>, but if we find
9308 more than one, we display each object with the terse method
9309 C<as_glimpse>.
9310
9311 =item get, make, test, install, clean  modules or distributions
9312
9313 These commands take any number of arguments and investigate what is
9314 necessary to perform the action. If the argument is a distribution
9315 file name (recognized by embedded slashes), it is processed. If it is
9316 a module, CPAN determines the distribution file in which this module
9317 is included and processes that, following any dependencies named in
9318 the module's META.yml or Makefile.PL (this behavior is controlled by
9319 the configuration parameter C<prerequisites_policy>.)
9320
9321 C<get> downloads a distribution file and untars or unzips it, C<make>
9322 builds it, C<test> runs the test suite, and C<install> installs it.
9323
9324 Any C<make> or C<test> are run unconditionally. An
9325
9326   install <distribution_file>
9327
9328 also is run unconditionally. But for
9329
9330   install <module>
9331
9332 CPAN checks if an install is actually needed for it and prints
9333 I<module up to date> in the case that the distribution file containing
9334 the module doesn't need to be updated.
9335
9336 CPAN also keeps track of what it has done within the current session
9337 and doesn't try to build a package a second time regardless if it
9338 succeeded or not. It does not repeat a test run if the test
9339 has been run successfully before. Same for install runs.
9340
9341 The C<force> pragma may precede another command (currently: C<get>,
9342 C<make>, C<test>, or C<install>) and executes the command from scratch
9343 and tries to continue in case of some errors. See the section below on
9344 The C<force> and the C<fforce> pragma.
9345
9346 The C<notest> pragma may be used to skip the test part in the build
9347 process.
9348
9349 Example:
9350
9351     cpan> notest install Tk
9352
9353 A C<clean> command results in a
9354
9355   make clean
9356
9357 being executed within the distribution file's working directory.
9358
9359 =item readme, perldoc, look module or distribution
9360
9361 C<readme> displays the README file of the associated distribution.
9362 C<Look> gets and untars (if not yet done) the distribution file,
9363 changes to the appropriate directory and opens a subshell process in
9364 that directory. C<perldoc> displays the pod documentation of the
9365 module in html or plain text format.
9366
9367 =item ls author
9368
9369 =item ls globbing_expression
9370
9371 The first form lists all distribution files in and below an author's
9372 CPAN directory as they are stored in the CHECKUMS files distributed on
9373 CPAN. The listing goes recursive into all subdirectories.
9374
9375 The second form allows to limit or expand the output with shell
9376 globbing as in the following examples:
9377
9378           ls JV/make*
9379           ls GSAR/*make*
9380           ls */*make*
9381
9382 The last example is very slow and outputs extra progress indicators
9383 that break the alignment of the result.
9384
9385 Note that globbing only lists directories explicitly asked for, for
9386 example FOO/* will not list FOO/bar/Acme-Sthg-n.nn.tar.gz. This may be
9387 regarded as a bug and may be changed in future versions.
9388
9389 =item failed
9390
9391 The C<failed> command reports all distributions that failed on one of
9392 C<make>, C<test> or C<install> for some reason in the currently
9393 running shell session.
9394
9395 =item Persistence between sessions
9396
9397 If the C<YAML> or the c<YAML::Syck> module is installed a record of
9398 the internal state of all modules is written to disk after each step.
9399 The files contain a signature of the currently running perl version
9400 for later perusal.
9401
9402 If the configurations variable C<build_dir_reuse> is set to a true
9403 value, then CPAN.pm reads the collected YAML files. If the stored
9404 signature matches the currently running perl the stored state is
9405 loaded into memory such that effectively persistence between sessions
9406 is established.
9407
9408 =item The C<force> and the C<fforce> pragma
9409
9410 To speed things up in complex installation scenarios, CPAN.pm keeps
9411 track of what it has already done and refuses to do some things a
9412 second time. A C<get>, a C<make>, and an C<install> are not repeated.
9413 A C<test> is only repeated if the previous test was unsuccessful. The
9414 diagnostic message when CPAN.pm refuses to do something a second time
9415 is one of I<Has already been >C<unwrapped|made|tested successfully> or
9416 something similar. Another situation where CPAN refuses to act is an
9417 C<install> if the according C<test> was not successful.
9418
9419 In all these cases, the user can override the goatish behaviour by
9420 prepending the command with the word force, for example:
9421
9422   cpan> force get Foo
9423   cpan> force make AUTHOR/Bar-3.14.tar.gz
9424   cpan> force test Baz
9425   cpan> force install Acme::Meta
9426
9427 Each I<forced> command is executed with the according part of its
9428 memory erased.
9429
9430 The C<fforce> pragma is a variant that emulates a C<force get> which
9431 erases the entire memory followed by the action specified, effectively
9432 restarting the whole get/make/test/install procedure from scratch.
9433
9434 =item Lockfile
9435
9436 Interactive sessions maintain a lockfile, per default C<~/.cpan/.lock>.
9437 Batch jobs can run without a lockfile and do not disturb each other.
9438
9439 The shell offers to run in I<degraded mode> when another process is
9440 holding the lockfile. This is an experimental feature that is not yet
9441 tested very well. This second shell then does not write the history
9442 file, does not use the metadata file and has a different prompt.
9443
9444 =item Signals
9445
9446 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
9447 in the cpan-shell it is intended that you can press C<^C> anytime and
9448 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
9449 to clean up and leave the shell loop. You can emulate the effect of a
9450 SIGTERM by sending two consecutive SIGINTs, which usually means by
9451 pressing C<^C> twice.
9452
9453 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
9454 SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl
9455 Build.PL> subprocess.
9456
9457 =back
9458
9459 =head2 CPAN::Shell
9460
9461 The commands that are available in the shell interface are methods in
9462 the package CPAN::Shell. If you enter the shell command, all your
9463 input is split by the Text::ParseWords::shellwords() routine which
9464 acts like most shells do. The first word is being interpreted as the
9465 method to be called and the rest of the words are treated as arguments
9466 to this method. Continuation lines are supported if a line ends with a
9467 literal backslash.
9468
9469 =head2 autobundle
9470
9471 C<autobundle> writes a bundle file into the
9472 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
9473 a list of all modules that are both available from CPAN and currently
9474 installed within @INC. The name of the bundle file is based on the
9475 current date and a counter.
9476
9477 =head2 hosts
9478
9479 This commands provides a statistical overview over recent download
9480 activities. The data for this is collected in the YAML file
9481 C<FTPstats.yml> in your C<cpan_home> directory. If no YAML module is
9482 configured or YAML not installed, then no stats are provided.
9483
9484 =head2 mkmyconfig
9485
9486 mkmyconfig() writes your own CPAN::MyConfig file into your ~/.cpan/
9487 directory so that you can save your own preferences instead of the
9488 system wide ones.
9489
9490 =head2 recompile
9491
9492 recompile() is a very special command in that it takes no argument and
9493 runs the make/test/install cycle with brute force over all installed
9494 dynamically loadable extensions (aka XS modules) with 'force' in
9495 effect. The primary purpose of this command is to finish a network
9496 installation. Imagine, you have a common source tree for two different
9497 architectures. You decide to do a completely independent fresh
9498 installation. You start on one architecture with the help of a Bundle
9499 file produced earlier. CPAN installs the whole Bundle for you, but
9500 when you try to repeat the job on the second architecture, CPAN
9501 responds with a C<"Foo up to date"> message for all modules. So you
9502 invoke CPAN's recompile on the second architecture and you're done.
9503
9504 Another popular use for C<recompile> is to act as a rescue in case your
9505 perl breaks binary compatibility. If one of the modules that CPAN uses
9506 is in turn depending on binary compatibility (so you cannot run CPAN
9507 commands), then you should try the CPAN::Nox module for recovery.
9508
9509 =head2 report Bundle|Distribution|Module
9510
9511 The C<report> command temporarily turns on the C<test_report> config
9512 variable, then runs the C<force test> command with the given
9513 arguments. The C<force> pragma is used to re-run the tests and repeat
9514 every step that might have failed before.
9515
9516 =head2 upgrade [Module|/Regex/]...
9517
9518 The C<upgrade> command first runs an C<r> command with the given
9519 arguments and then installs the newest versions of all modules that
9520 were listed by that.
9521
9522 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
9523
9524 Although it may be considered internal, the class hierarchy does matter
9525 for both users and programmer. CPAN.pm deals with above mentioned four
9526 classes, and all those classes share a set of methods. A classical
9527 single polymorphism is in effect. A metaclass object registers all
9528 objects of all kinds and indexes them with a string. The strings
9529 referencing objects have a separated namespace (well, not completely
9530 separated):
9531
9532          Namespace                         Class
9533
9534    words containing a "/" (slash)      Distribution
9535     words starting with Bundle::          Bundle
9536           everything else            Module or Author
9537
9538 Modules know their associated Distribution objects. They always refer
9539 to the most recent official release. Developers may mark their releases
9540 as unstable development versions (by inserting an underbar into the
9541 module version number which will also be reflected in the distribution
9542 name when you run 'make dist'), so the really hottest and newest
9543 distribution is not always the default.  If a module Foo circulates
9544 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
9545 way to install version 1.23 by saying
9546
9547     install Foo
9548
9549 This would install the complete distribution file (say
9550 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
9551 like to install version 1.23_90, you need to know where the
9552 distribution file resides on CPAN relative to the authors/id/
9553 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
9554 so you would have to say
9555
9556     install BAR/Foo-1.23_90.tar.gz
9557
9558 The first example will be driven by an object of the class
9559 CPAN::Module, the second by an object of class CPAN::Distribution.
9560
9561 =head2 Integrating local directories
9562
9563 Distribution objects are normally distributions from the CPAN, but
9564 there is a slightly degenerate case for Distribution objects, too, of
9565 projects held on the local disk. These distribution objects have the
9566 same name as the local directory and end with a dot. A dot by itself
9567 is also allowed for the current directory at the time CPAN.pm was
9568 used. All actions such as C<make>, C<test>, and C<install> are applied
9569 directly to that directory. This gives the command C<cpan .> an
9570 interesting touch: while the normal mantra of installing a CPAN module
9571 without CPAN.pm is one of
9572
9573     perl Makefile.PL                 perl Build.PL
9574            ( go and get prerequisites )
9575     make                             ./Build
9576     make test                        ./Build test
9577     make install                     ./Build install
9578
9579 the command C<cpan .> does all of this at once. It figures out which
9580 of the two mantras is appropriate, fetches and installs all
9581 prerequisites, cares for them recursively and finally finishes the
9582 installation of the module in the current directory, be it a CPAN
9583 module or not.
9584
9585 The typical usage case is for private modules or working copies of
9586 projects from remote repositories on the local disk.
9587
9588 =head1 PROGRAMMER'S INTERFACE
9589
9590 If you do not enter the shell, the available shell commands are both
9591 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
9592 functions in the calling package (C<install(...)>).  Before calling low-level
9593 commands it makes sense to initialize components of CPAN you need, e.g.:
9594
9595   CPAN::HandleConfig->load;
9596   CPAN::Shell::setup_output;
9597   CPAN::Index->reload;
9598
9599 High-level commands do such initializations automatically.
9600
9601 There's currently only one class that has a stable interface -
9602 CPAN::Shell. All commands that are available in the CPAN shell are
9603 methods of the class CPAN::Shell. Each of the commands that produce
9604 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
9605 the IDs of all modules within the list.
9606
9607 =over 2
9608
9609 =item expand($type,@things)
9610
9611 The IDs of all objects available within a program are strings that can
9612 be expanded to the corresponding real objects with the
9613 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
9614 list of CPAN::Module objects according to the C<@things> arguments
9615 given. In scalar context it only returns the first element of the
9616 list.
9617
9618 =item expandany(@things)
9619
9620 Like expand, but returns objects of the appropriate type, i.e.
9621 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
9622 CPAN::Distribution objects for distributions. Note: it does not expand
9623 to CPAN::Author objects.
9624
9625 =item Programming Examples
9626
9627 This enables the programmer to do operations that combine
9628 functionalities that are available in the shell.
9629
9630     # install everything that is outdated on my disk:
9631     perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
9632
9633     # install my favorite programs if necessary:
9634     for $mod (qw(Net::FTP Digest::SHA Data::Dumper)){
9635         CPAN::Shell->install($mod);
9636     }
9637
9638     # list all modules on my disk that have no VERSION number
9639     for $mod (CPAN::Shell->expand("Module","/./")){
9640         next unless $mod->inst_file;
9641         # MakeMaker convention for undefined $VERSION:
9642         next unless $mod->inst_version eq "undef";
9643         print "No VERSION in ", $mod->id, "\n";
9644     }
9645
9646     # find out which distribution on CPAN contains a module:
9647     print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
9648
9649 Or if you want to write a cronjob to watch The CPAN, you could list
9650 all modules that need updating. First a quick and dirty way:
9651
9652     perl -e 'use CPAN; CPAN::Shell->r;'
9653
9654 If you don't want to get any output in the case that all modules are
9655 up to date, you can parse the output of above command for the regular
9656 expression //modules are up to date// and decide to mail the output
9657 only if it doesn't match. Ick?
9658
9659 If you prefer to do it more in a programmer style in one single
9660 process, maybe something like this suits you better:
9661
9662   # list all modules on my disk that have newer versions on CPAN
9663   for $mod (CPAN::Shell->expand("Module","/./")){
9664     next unless $mod->inst_file;
9665     next if $mod->uptodate;
9666     printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
9667         $mod->id, $mod->inst_version, $mod->cpan_version;
9668   }
9669
9670 If that gives you too much output every day, you maybe only want to
9671 watch for three modules. You can write
9672
9673   for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
9674
9675 as the first line instead. Or you can combine some of the above
9676 tricks:
9677
9678   # watch only for a new mod_perl module
9679   $mod = CPAN::Shell->expand("Module","mod_perl");
9680   exit if $mod->uptodate;
9681   # new mod_perl arrived, let me know all update recommendations
9682   CPAN::Shell->r;
9683
9684 =back
9685
9686 =head2 Methods in the other Classes
9687
9688 =over 4
9689
9690 =item CPAN::Author::as_glimpse()
9691
9692 Returns a one-line description of the author
9693
9694 =item CPAN::Author::as_string()
9695
9696 Returns a multi-line description of the author
9697
9698 =item CPAN::Author::email()
9699
9700 Returns the author's email address
9701
9702 =item CPAN::Author::fullname()
9703
9704 Returns the author's name
9705
9706 =item CPAN::Author::name()
9707
9708 An alias for fullname
9709
9710 =item CPAN::Bundle::as_glimpse()
9711
9712 Returns a one-line description of the bundle
9713
9714 =item CPAN::Bundle::as_string()
9715
9716 Returns a multi-line description of the bundle
9717
9718 =item CPAN::Bundle::clean()
9719
9720 Recursively runs the C<clean> method on all items contained in the bundle.
9721
9722 =item CPAN::Bundle::contains()
9723
9724 Returns a list of objects' IDs contained in a bundle. The associated
9725 objects may be bundles, modules or distributions.
9726
9727 =item CPAN::Bundle::force($method,@args)
9728
9729 Forces CPAN to perform a task that it normally would have refused to
9730 do. Force takes as arguments a method name to be called and any number
9731 of additional arguments that should be passed to the called method.
9732 The internals of the object get the needed changes so that CPAN.pm
9733 does not refuse to take the action. The C<force> is passed recursively
9734 to all contained objects. See also the section above on the C<force>
9735 and the C<fforce> pragma.
9736
9737 =item CPAN::Bundle::get()
9738
9739 Recursively runs the C<get> method on all items contained in the bundle
9740
9741 =item CPAN::Bundle::inst_file()
9742
9743 Returns the highest installed version of the bundle in either @INC or
9744 C<$CPAN::Config->{cpan_home}>. Note that this is different from
9745 CPAN::Module::inst_file.
9746
9747 =item CPAN::Bundle::inst_version()
9748
9749 Like CPAN::Bundle::inst_file, but returns the $VERSION
9750
9751 =item CPAN::Bundle::uptodate()
9752
9753 Returns 1 if the bundle itself and all its members are uptodate.
9754
9755 =item CPAN::Bundle::install()
9756
9757 Recursively runs the C<install> method on all items contained in the bundle
9758
9759 =item CPAN::Bundle::make()
9760
9761 Recursively runs the C<make> method on all items contained in the bundle
9762
9763 =item CPAN::Bundle::readme()
9764
9765 Recursively runs the C<readme> method on all items contained in the bundle
9766
9767 =item CPAN::Bundle::test()
9768
9769 Recursively runs the C<test> method on all items contained in the bundle
9770
9771 =item CPAN::Distribution::as_glimpse()
9772
9773 Returns a one-line description of the distribution
9774
9775 =item CPAN::Distribution::as_string()
9776
9777 Returns a multi-line description of the distribution
9778
9779 =item CPAN::Distribution::author
9780
9781 Returns the CPAN::Author object of the maintainer who uploaded this
9782 distribution
9783
9784 =item CPAN::Distribution::clean()
9785
9786 Changes to the directory where the distribution has been unpacked and
9787 runs C<make clean> there.
9788
9789 =item CPAN::Distribution::containsmods()
9790
9791 Returns a list of IDs of modules contained in a distribution file.
9792 Only works for distributions listed in the 02packages.details.txt.gz
9793 file. This typically means that only the most recent version of a
9794 distribution is covered.
9795
9796 =item CPAN::Distribution::cvs_import()
9797
9798 Changes to the directory where the distribution has been unpacked and
9799 runs something like
9800
9801     cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
9802
9803 there.
9804
9805 =item CPAN::Distribution::dir()
9806
9807 Returns the directory into which this distribution has been unpacked.
9808
9809 =item CPAN::Distribution::force($method,@args)
9810
9811 Forces CPAN to perform a task that it normally would have refused to
9812 do. Force takes as arguments a method name to be called and any number
9813 of additional arguments that should be passed to the called method.
9814 The internals of the object get the needed changes so that CPAN.pm
9815 does not refuse to take the action. See also the section above on the
9816 C<force> and the C<fforce> pragma.
9817
9818 =item CPAN::Distribution::get()
9819
9820 Downloads the distribution from CPAN and unpacks it. Does nothing if
9821 the distribution has already been downloaded and unpacked within the
9822 current session.
9823
9824 =item CPAN::Distribution::install()
9825
9826 Changes to the directory where the distribution has been unpacked and
9827 runs the external command C<make install> there. If C<make> has not
9828 yet been run, it will be run first. A C<make test> will be issued in
9829 any case and if this fails, the install will be canceled. The
9830 cancellation can be avoided by letting C<force> run the C<install> for
9831 you.
9832
9833 This install method has only the power to install the distribution if
9834 there are no dependencies in the way. To install an object and all of
9835 its dependencies, use CPAN::Shell->install.
9836
9837 Note that install() gives no meaningful return value. See uptodate().
9838
9839 =item CPAN::Distribution::isa_perl()
9840
9841 Returns 1 if this distribution file seems to be a perl distribution.
9842 Normally this is derived from the file name only, but the index from
9843 CPAN can contain a hint to achieve a return value of true for other
9844 filenames too.
9845
9846 =item CPAN::Distribution::look()
9847
9848 Changes to the directory where the distribution has been unpacked and
9849 opens a subshell there. Exiting the subshell returns.
9850
9851 =item CPAN::Distribution::make()
9852
9853 First runs the C<get> method to make sure the distribution is
9854 downloaded and unpacked. Changes to the directory where the
9855 distribution has been unpacked and runs the external commands C<perl
9856 Makefile.PL> or C<perl Build.PL> and C<make> there.
9857
9858 =item CPAN::Distribution::perldoc()
9859
9860 Downloads the pod documentation of the file associated with a
9861 distribution (in html format) and runs it through the external
9862 command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
9863 isn't available, it converts it to plain text with external
9864 command html2text and runs it through the pager specified
9865 in C<$CPAN::Config->{pager}>
9866
9867 =item CPAN::Distribution::prefs()
9868
9869 Returns the hash reference from the first matching YAML file that the
9870 user has deposited in the C<prefs_dir/> directory. The first
9871 succeeding match wins. The files in the C<prefs_dir/> are processed
9872 alphabetically and the canonical distroname (e.g.
9873 AUTHOR/Foo-Bar-3.14.tar.gz) is matched against the regular expressions
9874 stored in the $root->{match}{distribution} attribute value.
9875 Additionally all module names contained in a distribution are matched
9876 agains the regular expressions in the $root->{match}{module} attribute
9877 value. The two match values are ANDed together. Each of the two
9878 attributes are optional.
9879
9880 =item CPAN::Distribution::prereq_pm()
9881
9882 Returns the hash reference that has been announced by a distribution
9883 as the merge of the C<requires> element and the C<build_requires>
9884 element of the META.yml or the C<PREREQ_PM> hash in the
9885 C<Makefile.PL>. Note: works only after an attempt has been made to
9886 C<make> the distribution. Returns undef otherwise.
9887
9888 =item CPAN::Distribution::readme()
9889
9890 Downloads the README file associated with a distribution and runs it
9891 through the pager specified in C<$CPAN::Config->{pager}>.
9892
9893 =item CPAN::Distribution::read_yaml()
9894
9895 Returns the content of the META.yml of this distro as a hashref. Note:
9896 works only after an attempt has been made to C<make> the distribution.
9897 Returns undef otherwise. Also returns undef if the content of META.yml
9898 is dynamic.
9899
9900 =item CPAN::Distribution::test()
9901
9902 Changes to the directory where the distribution has been unpacked and
9903 runs C<make test> there.
9904
9905 =item CPAN::Distribution::uptodate()
9906
9907 Returns 1 if all the modules contained in the distribution are
9908 uptodate. Relies on containsmods.
9909
9910 =item CPAN::Index::force_reload()
9911
9912 Forces a reload of all indices.
9913
9914 =item CPAN::Index::reload()
9915
9916 Reloads all indices if they have not been read for more than
9917 C<$CPAN::Config->{index_expire}> days.
9918
9919 =item CPAN::InfoObj::dump()
9920
9921 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
9922 inherit this method. It prints the data structure associated with an
9923 object. Useful for debugging. Note: the data structure is considered
9924 internal and thus subject to change without notice.
9925
9926 =item CPAN::Module::as_glimpse()
9927
9928 Returns a one-line description of the module in four columns: The
9929 first column contains the word C<Module>, the second column consists
9930 of one character: an equals sign if this module is already installed
9931 and uptodate, a less-than sign if this module is installed but can be
9932 upgraded, and a space if the module is not installed. The third column
9933 is the name of the module and the fourth column gives maintainer or
9934 distribution information.
9935
9936 =item CPAN::Module::as_string()
9937
9938 Returns a multi-line description of the module
9939
9940 =item CPAN::Module::clean()
9941
9942 Runs a clean on the distribution associated with this module.
9943
9944 =item CPAN::Module::cpan_file()
9945
9946 Returns the filename on CPAN that is associated with the module.
9947
9948 =item CPAN::Module::cpan_version()
9949
9950 Returns the latest version of this module available on CPAN.
9951
9952 =item CPAN::Module::cvs_import()
9953
9954 Runs a cvs_import on the distribution associated with this module.
9955
9956 =item CPAN::Module::description()
9957
9958 Returns a 44 character description of this module. Only available for
9959 modules listed in The Module List (CPAN/modules/00modlist.long.html
9960 or 00modlist.long.txt.gz)
9961
9962 =item CPAN::Module::distribution()
9963
9964 Returns the CPAN::Distribution object that contains the current
9965 version of this module.
9966
9967 =item CPAN::Module::dslip_status()
9968
9969 Returns a hash reference. The keys of the hash are the letters C<D>,
9970 C<S>, C<L>, C<I>, and <P>, for development status, support level,
9971 language, interface and public licence respectively. The data for the
9972 DSLIP status are collected by pause.perl.org when authors register
9973 their namespaces. The values of the 5 hash elements are one-character
9974 words whose meaning is described in the table below. There are also 5
9975 hash elements C<DV>, C<SV>, C<LV>, C<IV>, and <PV> that carry a more
9976 verbose value of the 5 status variables.
9977
9978 Where the 'DSLIP' characters have the following meanings:
9979
9980   D - Development Stage  (Note: *NO IMPLIED TIMESCALES*):
9981     i   - Idea, listed to gain consensus or as a placeholder
9982     c   - under construction but pre-alpha (not yet released)
9983     a/b - Alpha/Beta testing
9984     R   - Released
9985     M   - Mature (no rigorous definition)
9986     S   - Standard, supplied with Perl 5
9987
9988   S - Support Level:
9989     m   - Mailing-list
9990     d   - Developer
9991     u   - Usenet newsgroup comp.lang.perl.modules
9992     n   - None known, try comp.lang.perl.modules
9993     a   - abandoned; volunteers welcome to take over maintainance
9994
9995   L - Language Used:
9996     p   - Perl-only, no compiler needed, should be platform independent
9997     c   - C and perl, a C compiler will be needed
9998     h   - Hybrid, written in perl with optional C code, no compiler needed
9999     +   - C++ and perl, a C++ compiler will be needed
10000     o   - perl and another language other than C or C++
10001
10002   I - Interface Style
10003     f   - plain Functions, no references used
10004     h   - hybrid, object and function interfaces available
10005     n   - no interface at all (huh?)
10006     r   - some use of unblessed References or ties
10007     O   - Object oriented using blessed references and/or inheritance
10008
10009   P - Public License
10010     p   - Standard-Perl: user may choose between GPL and Artistic
10011     g   - GPL: GNU General Public License
10012     l   - LGPL: "GNU Lesser General Public License" (previously known as
10013           "GNU Library General Public License")
10014     b   - BSD: The BSD License
10015     a   - Artistic license alone
10016     o   - open source: appoved by www.opensource.org
10017     d   - allows distribution without restrictions
10018     r   - restricted distribtion
10019     n   - no license at all
10020
10021 =item CPAN::Module::force($method,@args)
10022
10023 Forces CPAN to perform a task that it normally would have refused to
10024 do. Force takes as arguments a method name to be called and any number
10025 of additional arguments that should be passed to the called method.
10026 The internals of the object get the needed changes so that CPAN.pm
10027 does not refuse to take the action. See also the section above on the
10028 C<force> and the C<fforce> pragma.
10029
10030 =item CPAN::Module::get()
10031
10032 Runs a get on the distribution associated with this module.
10033
10034 =item CPAN::Module::inst_file()
10035
10036 Returns the filename of the module found in @INC. The first file found
10037 is reported just like perl itself stops searching @INC when it finds a
10038 module.
10039
10040 =item CPAN::Module::available_file()
10041
10042 Returns the filename of the module found in PERL5LIB or @INC. The
10043 first file found is reported. The advantage of this method over
10044 C<inst_file> is that modules that have been tested but not yet
10045 installed are included because PERL5LIB keeps track of tested modules.
10046
10047 =item CPAN::Module::inst_version()
10048
10049 Returns the version number of the installed module in readable format.
10050
10051 =item CPAN::Module::available_version()
10052
10053 Returns the version number of the available module in readable format.
10054
10055 =item CPAN::Module::install()
10056
10057 Runs an C<install> on the distribution associated with this module.
10058
10059 =item CPAN::Module::look()
10060
10061 Changes to the directory where the distribution associated with this
10062 module has been unpacked and opens a subshell there. Exiting the
10063 subshell returns.
10064
10065 =item CPAN::Module::make()
10066
10067 Runs a C<make> on the distribution associated with this module.
10068
10069 =item CPAN::Module::manpage_headline()
10070
10071 If module is installed, peeks into the module's manpage, reads the
10072 headline and returns it. Moreover, if the module has been downloaded
10073 within this session, does the equivalent on the downloaded module even
10074 if it is not installed.
10075
10076 =item CPAN::Module::perldoc()
10077
10078 Runs a C<perldoc> on this module.
10079
10080 =item CPAN::Module::readme()
10081
10082 Runs a C<readme> on the distribution associated with this module.
10083
10084 =item CPAN::Module::test()
10085
10086 Runs a C<test> on the distribution associated with this module.
10087
10088 =item CPAN::Module::uptodate()
10089
10090 Returns 1 if the module is installed and up-to-date.
10091
10092 =item CPAN::Module::userid()
10093
10094 Returns the author's ID of the module.
10095
10096 =back
10097
10098 =head2 Cache Manager
10099
10100 Currently the cache manager only keeps track of the build directory
10101 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
10102 deletes complete directories below C<build_dir> as soon as the size of
10103 all directories there gets bigger than $CPAN::Config->{build_cache}
10104 (in MB). The contents of this cache may be used for later
10105 re-installations that you intend to do manually, but will never be
10106 trusted by CPAN itself. This is due to the fact that the user might
10107 use these directories for building modules on different architectures.
10108
10109 There is another directory ($CPAN::Config->{keep_source_where}) where
10110 the original distribution files are kept. This directory is not
10111 covered by the cache manager and must be controlled by the user. If
10112 you choose to have the same directory as build_dir and as
10113 keep_source_where directory, then your sources will be deleted with
10114 the same fifo mechanism.
10115
10116 =head2 Bundles
10117
10118 A bundle is just a perl module in the namespace Bundle:: that does not
10119 define any functions or methods. It usually only contains documentation.
10120
10121 It starts like a perl module with a package declaration and a $VERSION
10122 variable. After that the pod section looks like any other pod with the
10123 only difference being that I<one special pod section> exists starting with
10124 (verbatim):
10125
10126         =head1 CONTENTS
10127
10128 In this pod section each line obeys the format
10129
10130         Module_Name [Version_String] [- optional text]
10131
10132 The only required part is the first field, the name of a module
10133 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
10134 of the line is optional. The comment part is delimited by a dash just
10135 as in the man page header.
10136
10137 The distribution of a bundle should follow the same convention as
10138 other distributions.
10139
10140 Bundles are treated specially in the CPAN package. If you say 'install
10141 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
10142 the modules in the CONTENTS section of the pod. You can install your
10143 own Bundles locally by placing a conformant Bundle file somewhere into
10144 your @INC path. The autobundle() command which is available in the
10145 shell interface does that for you by including all currently installed
10146 modules in a snapshot bundle file.
10147
10148 =head1 PREREQUISITES
10149
10150 If you have a local mirror of CPAN and can access all files with
10151 "file:" URLs, then you only need a perl better than perl5.003 to run
10152 this module. Otherwise Net::FTP is strongly recommended. LWP may be
10153 required for non-UNIX systems or if your nearest CPAN site is
10154 associated with a URL that is not C<ftp:>.
10155
10156 If you have neither Net::FTP nor LWP, there is a fallback mechanism
10157 implemented for an external ftp command or for an external lynx
10158 command.
10159
10160 =head1 UTILITIES
10161
10162 =head2 Finding packages and VERSION
10163
10164 This module presumes that all packages on CPAN
10165
10166 =over 2
10167
10168 =item *
10169
10170 declare their $VERSION variable in an easy to parse manner. This
10171 prerequisite can hardly be relaxed because it consumes far too much
10172 memory to load all packages into the running program just to determine
10173 the $VERSION variable. Currently all programs that are dealing with
10174 version use something like this
10175
10176     perl -MExtUtils::MakeMaker -le \
10177         'print MM->parse_version(shift)' filename
10178
10179 If you are author of a package and wonder if your $VERSION can be
10180 parsed, please try the above method.
10181
10182 =item *
10183
10184 come as compressed or gzipped tarfiles or as zip files and contain a
10185 C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
10186 without much enthusiasm).
10187
10188 =back
10189
10190 =head2 Debugging
10191
10192 The debugging of this module is a bit complex, because we have
10193 interferences of the software producing the indices on CPAN, of the
10194 mirroring process on CPAN, of packaging, of configuration, of
10195 synchronicity, and of bugs within CPAN.pm.
10196
10197 For debugging the code of CPAN.pm itself in interactive mode some more
10198 or less useful debugging aid can be turned on for most packages within
10199 CPAN.pm with one of
10200
10201 =over 2
10202
10203 =item o debug package...
10204
10205 sets debug mode for packages.
10206
10207 =item o debug -package...
10208
10209 unsets debug mode for packages.
10210
10211 =item o debug all
10212
10213 turns debugging on for all packages.
10214
10215 =item o debug number
10216
10217 =back
10218
10219 which sets the debugging packages directly. Note that C<o debug 0>
10220 turns debugging off.
10221
10222 What seems quite a successful strategy is the combination of C<reload
10223 cpan> and the debugging switches. Add a new debug statement while
10224 running in the shell and then issue a C<reload cpan> and see the new
10225 debugging messages immediately without losing the current context.
10226
10227 C<o debug> without an argument lists the valid package names and the
10228 current set of packages in debugging mode. C<o debug> has built-in
10229 completion support.
10230
10231 For debugging of CPAN data there is the C<dump> command which takes
10232 the same arguments as make/test/install and outputs each object's
10233 Data::Dumper dump. If an argument looks like a perl variable and
10234 contains one of C<$>, C<@> or C<%>, it is eval()ed and fed to
10235 Data::Dumper directly.
10236
10237 =head2 Floppy, Zip, Offline Mode
10238
10239 CPAN.pm works nicely without network too. If you maintain machines
10240 that are not networked at all, you should consider working with file:
10241 URLs. Of course, you have to collect your modules somewhere first. So
10242 you might use CPAN.pm to put together all you need on a networked
10243 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
10244 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
10245 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
10246 with this floppy. See also below the paragraph about CD-ROM support.
10247
10248 =head2 Basic Utilities for Programmers
10249
10250 =over 2
10251
10252 =item has_inst($module)
10253
10254 Returns true if the module is installed. Used to load all modules into
10255 the running CPAN.pm which are considered optional. The config variable
10256 C<dontload_list> can be used to intercept the C<has_inst()> call such
10257 that an optional module is not loaded despite being available. For
10258 example the following command will prevent that C<YAML.pm> is being
10259 loaded:
10260
10261     cpan> o conf dontload_list push YAML
10262
10263 See the source for details.
10264
10265 =item has_usable($module)
10266
10267 Returns true if the module is installed and is in a usable state. Only
10268 useful for a handful of modules that are used internally. See the
10269 source for details.
10270
10271 =item instance($module)
10272
10273 The constructor for all the singletons used to represent modules,
10274 distributions, authors and bundles. If the object already exists, this
10275 method returns the object, otherwise it calls the constructor.
10276
10277 =back
10278
10279 =head1 CONFIGURATION
10280
10281 When the CPAN module is used for the first time, a configuration
10282 dialog tries to determine a couple of site specific options. The
10283 result of the dialog is stored in a hash reference C< $CPAN::Config >
10284 in a file CPAN/Config.pm.
10285
10286 The default values defined in the CPAN/Config.pm file can be
10287 overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
10288 best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
10289 added to the search path of the CPAN module before the use() or
10290 require() statements. The mkmyconfig command writes this file for you.
10291
10292 The C<o conf> command has various bells and whistles:
10293
10294 =over
10295
10296 =item completion support
10297
10298 If you have a ReadLine module installed, you can hit TAB at any point
10299 of the commandline and C<o conf> will offer you completion for the
10300 built-in subcommands and/or config variable names.
10301
10302 =item displaying some help: o conf help
10303
10304 Displays a short help
10305
10306 =item displaying current values: o conf [KEY]
10307
10308 Displays the current value(s) for this config variable. Without KEY
10309 displays all subcommands and config variables.
10310
10311 Example:
10312
10313   o conf shell
10314
10315 =item changing of scalar values: o conf KEY VALUE
10316
10317 Sets the config variable KEY to VALUE. The empty string can be
10318 specified as usual in shells, with C<''> or C<"">
10319
10320 Example:
10321
10322   o conf wget /usr/bin/wget
10323
10324 =item changing of list values: o conf KEY SHIFT|UNSHIFT|PUSH|POP|SPLICE|LIST
10325
10326 If a config variable name ends with C<list>, it is a list. C<o conf
10327 KEY shift> removes the first element of the list, C<o conf KEY pop>
10328 removes the last element of the list. C<o conf KEYS unshift LIST>
10329 prepends a list of values to the list, C<o conf KEYS push LIST>
10330 appends a list of valued to the list.
10331
10332 Likewise, C<o conf KEY splice LIST> passes the LIST to the according
10333 splice command.
10334
10335 Finally, any other list of arguments is taken as a new list value for
10336 the KEY variable discarding the previous value.
10337
10338 Examples:
10339
10340   o conf urllist unshift http://cpan.dev.local/CPAN
10341   o conf urllist splice 3 1
10342   o conf urllist http://cpan1.local http://cpan2.local ftp://ftp.perl.org
10343
10344 =item interactive editing: o conf init [MATCH|LIST]
10345
10346 Runs an interactive configuration dialog for matching variables.
10347 Without argument runs the dialog over all supported config variables.
10348 To specify a MATCH the argument must be enclosed by slashes.
10349
10350 Examples:
10351
10352   o conf init ftp_passive ftp_proxy
10353   o conf init /color/
10354
10355 =item reverting to saved: o conf defaults
10356
10357 Reverts all config variables to the state in the saved config file.
10358
10359 =item saving the config: o conf commit
10360
10361 Saves all config variables to the current config file (CPAN/Config.pm
10362 or CPAN/MyConfig.pm that was loaded at start).
10363
10364 =back
10365
10366 The configuration dialog can be started any time later again by
10367 issuing the command C< o conf init > in the CPAN shell. A subset of
10368 the configuration dialog can be run by issuing C<o conf init WORD>
10369 where WORD is any valid config variable or a regular expression.
10370
10371 =head2 Config Variables
10372
10373 Currently the following keys in the hash reference $CPAN::Config are
10374 defined:
10375
10376   applypatch         path to external prg
10377   auto_commit        commit all changes to config variables to disk
10378   build_cache        size of cache for directories to build modules
10379   build_dir          locally accessible directory to build modules
10380   build_dir_reuse    boolean if distros in build_dir are persistent
10381   build_requires_install_policy
10382                      to install or not to install: when a module is
10383                      only needed for building. yes|no|ask/yes|ask/no
10384   bzip2              path to external prg
10385   cache_metadata     use serializer to cache metadata
10386   commands_quote     prefered character to use for quoting external
10387                      commands when running them. Defaults to double
10388                      quote on Windows, single tick everywhere else;
10389                      can be set to space to disable quoting
10390   check_sigs         if signatures should be verified
10391   colorize_debug     Term::ANSIColor attributes for debugging output
10392   colorize_output    boolean if Term::ANSIColor should colorize output
10393   colorize_print     Term::ANSIColor attributes for normal output
10394   colorize_warn      Term::ANSIColor attributes for warnings
10395   commandnumber_in_prompt
10396                      boolean if you want to see current command number
10397   cpan_home          local directory reserved for this package
10398   curl               path to external prg
10399   dontload_hash      DEPRECATED
10400   dontload_list      arrayref: modules in the list will not be
10401                      loaded by the CPAN::has_inst() routine
10402   ftp                path to external prg
10403   ftp_passive        if set, the envariable FTP_PASSIVE is set for downloads
10404   ftp_proxy          proxy host for ftp requests
10405   getcwd             see below
10406   gpg                path to external prg
10407   gzip               location of external program gzip
10408   histfile           file to maintain history between sessions
10409   histsize           maximum number of lines to keep in histfile
10410   http_proxy         proxy host for http requests
10411   inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
10412                      after this many seconds inactivity. Set to 0 to
10413                      never break.
10414   index_expire       after this many days refetch index files
10415   inhibit_startup_message
10416                      if true, does not print the startup message
10417   keep_source_where  directory in which to keep the source (if we do)
10418   lynx               path to external prg
10419   make               location of external make program
10420   make_arg           arguments that should always be passed to 'make'
10421   make_install_make_command
10422                      the make command for running 'make install', for
10423                      example 'sudo make'
10424   make_install_arg   same as make_arg for 'make install'
10425   makepl_arg         arguments passed to 'perl Makefile.PL'
10426   mbuild_arg         arguments passed to './Build'
10427   mbuild_install_arg arguments passed to './Build install'
10428   mbuild_install_build_command
10429                      command to use instead of './Build' when we are
10430                      in the install stage, for example 'sudo ./Build'
10431   mbuildpl_arg       arguments passed to 'perl Build.PL'
10432   ncftp              path to external prg
10433   ncftpget           path to external prg
10434   no_proxy           don't proxy to these hosts/domains (comma separated list)
10435   pager              location of external program more (or any pager)
10436   password           your password if you CPAN server wants one
10437   patch              path to external prg
10438   prefer_installer   legal values are MB and EUMM: if a module comes
10439                      with both a Makefile.PL and a Build.PL, use the
10440                      former (EUMM) or the latter (MB); if the module
10441                      comes with only one of the two, that one will be
10442                      used in any case
10443   prerequisites_policy
10444                      what to do if you are missing module prerequisites
10445                      ('follow' automatically, 'ask' me, or 'ignore')
10446   prefs_dir          local directory to store per-distro build options
10447   proxy_user         username for accessing an authenticating proxy
10448   proxy_pass         password for accessing an authenticating proxy
10449   randomize_urllist  add some randomness to the sequence of the urllist
10450   scan_cache         controls scanning of cache ('atstart' or 'never')
10451   shell              your favorite shell
10452   show_upload_date   boolean if commands should try to determine upload date
10453   tar                location of external program tar
10454   term_is_latin      if true internal UTF-8 is translated to ISO-8859-1
10455                      (and nonsense for characters outside latin range)
10456   term_ornaments     boolean to turn ReadLine ornamenting on/off
10457   test_report        email test reports (if CPAN::Reporter is installed)
10458   unzip              location of external program unzip
10459   urllist            arrayref to nearby CPAN sites (or equivalent locations)
10460   use_sqlite         use CPAN::SQLite for metadata storage (fast and lean)
10461   username           your username if you CPAN server wants one
10462   wait_list          arrayref to a wait server to try (See CPAN::WAIT)
10463   wget               path to external prg
10464   yaml_module        which module to use to read/write YAML files
10465
10466 You can set and query each of these options interactively in the cpan
10467 shell with the command set defined within the C<o conf> command:
10468
10469 =over 2
10470
10471 =item C<o conf E<lt>scalar optionE<gt>>
10472
10473 prints the current value of the I<scalar option>
10474
10475 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
10476
10477 Sets the value of the I<scalar option> to I<value>
10478
10479 =item C<o conf E<lt>list optionE<gt>>
10480
10481 prints the current value of the I<list option> in MakeMaker's
10482 neatvalue format.
10483
10484 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
10485
10486 shifts or pops the array in the I<list option> variable
10487
10488 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
10489
10490 works like the corresponding perl commands.
10491
10492 =back
10493
10494 =head2 CPAN::anycwd($path): Note on config variable getcwd
10495
10496 CPAN.pm changes the current working directory often and needs to
10497 determine its own current working directory. Per default it uses
10498 Cwd::cwd but if this doesn't work on your system for some reason,
10499 alternatives can be configured according to the following table:
10500
10501 =over 2
10502
10503 =item cwd
10504
10505 Calls Cwd::cwd
10506
10507 =item getcwd
10508
10509 Calls Cwd::getcwd
10510
10511 =item fastcwd
10512
10513 Calls Cwd::fastcwd
10514
10515 =item backtickcwd
10516
10517 Calls the external command cwd.
10518
10519 =back
10520
10521 =head2 Note on the format of the urllist parameter
10522
10523 urllist parameters are URLs according to RFC 1738. We do a little
10524 guessing if your URL is not compliant, but if you have problems with
10525 C<file> URLs, please try the correct format. Either:
10526
10527     file://localhost/whatever/ftp/pub/CPAN/
10528
10529 or
10530
10531     file:///home/ftp/pub/CPAN/
10532
10533 =head2 urllist parameter has CD-ROM support
10534
10535 The C<urllist> parameter of the configuration table contains a list of
10536 URLs that are to be used for downloading. If the list contains any
10537 C<file> URLs, CPAN always tries to get files from there first. This
10538 feature is disabled for index files. So the recommendation for the
10539 owner of a CD-ROM with CPAN contents is: include your local, possibly
10540 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
10541
10542   o conf urllist push file://localhost/CDROM/CPAN
10543
10544 CPAN.pm will then fetch the index files from one of the CPAN sites
10545 that come at the beginning of urllist. It will later check for each
10546 module if there is a local copy of the most recent version.
10547
10548 Another peculiarity of urllist is that the site that we could
10549 successfully fetch the last file from automatically gets a preference
10550 token and is tried as the first site for the next request. So if you
10551 add a new site at runtime it may happen that the previously preferred
10552 site will be tried another time. This means that if you want to disallow
10553 a site for the next transfer, it must be explicitly removed from
10554 urllist.
10555
10556 =head2 Maintaining the urllist parameter
10557
10558 If you have YAML.pm (or some other YAML module configured in
10559 C<yaml_module>) installed, CPAN.pm collects a few statistical data
10560 about recent downloads. You can view the statistics with the C<hosts>
10561 command or inspect them directly by looking into the C<FTPstats.yml>
10562 file in your C<cpan_home> directory.
10563
10564 To get some interesting statistics it is recommended to set the
10565 C<randomize_urllist> parameter that introduces some amount of
10566 randomness into the URL selection.
10567
10568 =head2 prefs_dir for avoiding interactive questions (ALPHA)
10569
10570 (B<Note:> This feature has been introduced in CPAN.pm 1.8854 and is
10571 still considered experimental and may still be changed)
10572
10573 The files in the directory specified in C<prefs_dir> are YAML files
10574 that specify how CPAN.pm shall treat distributions that deviate from
10575 the normal non-interactive model of building and installing CPAN
10576 modules.
10577
10578 Some modules try to get some data from the user interactively thus
10579 disturbing the installation of large bundles like Phalanx100 or
10580 modules like Plagger.
10581
10582 CPAN.pm can use YAML files to either pass additional arguments to one
10583 of the four commands, set environment variables or instantiate an
10584 Expect object that reads from the console and enters answers on your
10585 behalf (latter option requires Expect.pm installed). A further option
10586 is to apply patches from the local disk or from CPAN.
10587
10588 CPAN.pm comes with a couple of such YAML files. The structure is
10589 currently not documented because in flux. Please see the distroprefs
10590 directory of the CPAN distribution for examples and follow the
10591 C<00.README> file in there.
10592
10593 Please note that setting the environment variable PERL_MM_USE_DEFAULT
10594 to a true value can also get you a long way if you want to always pick
10595 the default answers. But this only works if the author of a package
10596 used the prompt function provided by ExtUtils::MakeMaker and if the
10597 defaults are OK for you.
10598
10599 =head1 SECURITY
10600
10601 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
10602 install foreign, unmasked, unsigned code on your machine. We compare
10603 to a checksum that comes from the net just as the distribution file
10604 itself. But we try to make it easy to add security on demand:
10605
10606 =head2 Cryptographically signed modules
10607
10608 Since release 1.77 CPAN.pm has been able to verify cryptographically
10609 signed module distributions using Module::Signature.  The CPAN modules
10610 can be signed by their authors, thus giving more security.  The simple
10611 unsigned MD5 checksums that were used before by CPAN protect mainly
10612 against accidental file corruption.
10613
10614 You will need to have Module::Signature installed, which in turn
10615 requires that you have at least one of Crypt::OpenPGP module or the
10616 command-line F<gpg> tool installed.
10617
10618 You will also need to be able to connect over the Internet to the public
10619 keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
10620
10621 The configuration parameter check_sigs is there to turn signature
10622 checking on or off.
10623
10624 =head1 EXPORT
10625
10626 Most functions in package CPAN are exported per default. The reason
10627 for this is that the primary use is intended for the cpan shell or for
10628 one-liners.
10629
10630 =head1 ENVIRONMENT
10631
10632 When the CPAN shell enters a subshell via the look command, it sets
10633 the environment CPAN_SHELL_LEVEL to 1 or increments it if it is
10634 already set.
10635
10636 When CPAN runs, it sets the environment variable PERL5_CPAN_IS_RUNNING.
10637
10638 When the config variable ftp_passive is set, all downloads will be run
10639 with the environment variable FTP_PASSIVE set to this value. This is
10640 in general a good idea as it influences both Net::FTP and LWP based
10641 connections. The same effect can be achieved by starting the cpan
10642 shell with this environment variable set. For Net::FTP alone, one can
10643 also always set passive mode by running libnetcfg.
10644
10645 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
10646
10647 Populating a freshly installed perl with my favorite modules is pretty
10648 easy if you maintain a private bundle definition file. To get a useful
10649 blueprint of a bundle definition file, the command autobundle can be used
10650 on the CPAN shell command line. This command writes a bundle definition
10651 file for all modules that are installed for the currently running perl
10652 interpreter. It's recommended to run this command only once and from then
10653 on maintain the file manually under a private name, say
10654 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
10655
10656     cpan> install Bundle::my_bundle
10657
10658 then answer a few questions and then go out for a coffee.
10659
10660 Maintaining a bundle definition file means keeping track of two
10661 things: dependencies and interactivity. CPAN.pm sometimes fails on
10662 calculating dependencies because not all modules define all MakeMaker
10663 attributes correctly, so a bundle definition file should specify
10664 prerequisites as early as possible. On the other hand, it's a bit
10665 annoying that many distributions need some interactive configuring. So
10666 what I try to accomplish in my private bundle file is to have the
10667 packages that need to be configured early in the file and the gentle
10668 ones later, so I can go out after a few minutes and leave CPAN.pm
10669 untended.
10670
10671 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
10672
10673 Thanks to Graham Barr for contributing the following paragraphs about
10674 the interaction between perl, and various firewall configurations. For
10675 further information on firewalls, it is recommended to consult the
10676 documentation that comes with the ncftp program. If you are unable to
10677 go through the firewall with a simple Perl setup, it is very likely
10678 that you can configure ncftp so that it works for your firewall.
10679
10680 =head2 Three basic types of firewalls
10681
10682 Firewalls can be categorized into three basic types.
10683
10684 =over 4
10685
10686 =item http firewall
10687
10688 This is where the firewall machine runs a web server and to access the
10689 outside world you must do it via the web server. If you set environment
10690 variables like http_proxy or ftp_proxy to a values beginning with http://
10691 or in your web browser you have to set proxy information then you know
10692 you are running an http firewall.
10693
10694 To access servers outside these types of firewalls with perl (even for
10695 ftp) you will need to use LWP.
10696
10697 =item ftp firewall
10698
10699 This where the firewall machine runs an ftp server. This kind of
10700 firewall will only let you access ftp servers outside the firewall.
10701 This is usually done by connecting to the firewall with ftp, then
10702 entering a username like "user@outside.host.com"
10703
10704 To access servers outside these type of firewalls with perl you
10705 will need to use Net::FTP.
10706
10707 =item One way visibility
10708
10709 I say one way visibility as these firewalls try to make themselves look
10710 invisible to the users inside the firewall. An FTP data connection is
10711 normally created by sending the remote server your IP address and then
10712 listening for the connection. But the remote server will not be able to
10713 connect to you because of the firewall. So for these types of firewall
10714 FTP connections need to be done in a passive mode.
10715
10716 There are two that I can think off.
10717
10718 =over 4
10719
10720 =item SOCKS
10721
10722 If you are using a SOCKS firewall you will need to compile perl and link
10723 it with the SOCKS library, this is what is normally called a 'socksified'
10724 perl. With this executable you will be able to connect to servers outside
10725 the firewall as if it is not there.
10726
10727 =item IP Masquerade
10728
10729 This is the firewall implemented in the Linux kernel, it allows you to
10730 hide a complete network behind one IP address. With this firewall no
10731 special compiling is needed as you can access hosts directly.
10732
10733 For accessing ftp servers behind such firewalls you usually need to
10734 set the environment variable C<FTP_PASSIVE> or the config variable
10735 ftp_passive to a true value.
10736
10737 =back
10738
10739 =back
10740
10741 =head2 Configuring lynx or ncftp for going through a firewall
10742
10743 If you can go through your firewall with e.g. lynx, presumably with a
10744 command such as
10745
10746     /usr/local/bin/lynx -pscott:tiger
10747
10748 then you would configure CPAN.pm with the command
10749
10750     o conf lynx "/usr/local/bin/lynx -pscott:tiger"
10751
10752 That's all. Similarly for ncftp or ftp, you would configure something
10753 like
10754
10755     o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
10756
10757 Your mileage may vary...
10758
10759 =head1 FAQ
10760
10761 =over 4
10762
10763 =item 1)
10764
10765 I installed a new version of module X but CPAN keeps saying,
10766 I have the old version installed
10767
10768 Most probably you B<do> have the old version installed. This can
10769 happen if a module installs itself into a different directory in the
10770 @INC path than it was previously installed. This is not really a
10771 CPAN.pm problem, you would have the same problem when installing the
10772 module manually. The easiest way to prevent this behaviour is to add
10773 the argument C<UNINST=1> to the C<make install> call, and that is why
10774 many people add this argument permanently by configuring
10775
10776   o conf make_install_arg UNINST=1
10777
10778 =item 2)
10779
10780 So why is UNINST=1 not the default?
10781
10782 Because there are people who have their precise expectations about who
10783 may install where in the @INC path and who uses which @INC array. In
10784 fine tuned environments C<UNINST=1> can cause damage.
10785
10786 =item 3)
10787
10788 I want to clean up my mess, and install a new perl along with
10789 all modules I have. How do I go about it?
10790
10791 Run the autobundle command for your old perl and optionally rename the
10792 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
10793 with the Configure option prefix, e.g.
10794
10795     ./Configure -Dprefix=/usr/local/perl-5.6.78.9
10796
10797 Install the bundle file you produced in the first step with something like
10798
10799     cpan> install Bundle::mybundle
10800
10801 and you're done.
10802
10803 =item 4)
10804
10805 When I install bundles or multiple modules with one command
10806 there is too much output to keep track of.
10807
10808 You may want to configure something like
10809
10810   o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
10811   o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
10812
10813 so that STDOUT is captured in a file for later inspection.
10814
10815
10816 =item 5)
10817
10818 I am not root, how can I install a module in a personal directory?
10819
10820 First of all, you will want to use your own configuration, not the one
10821 that your root user installed. If you do not have permission to write
10822 in the cpan directory that root has configured, you will be asked if
10823 you want to create your own config. Answering "yes" will bring you into
10824 CPAN's configuration stage, using the system config for all defaults except
10825 things that have to do with CPAN's work directory, saving your choices to
10826 your MyConfig.pm file.
10827
10828 You can also manually initiate this process with the following command:
10829
10830     % perl -MCPAN -e 'mkmyconfig'
10831
10832 or by running
10833
10834     mkmyconfig
10835
10836 from the CPAN shell.
10837
10838 You will most probably also want to configure something like this:
10839
10840   o conf makepl_arg "LIB=~/myperl/lib \
10841                     INSTALLMAN1DIR=~/myperl/man/man1 \
10842                     INSTALLMAN3DIR=~/myperl/man/man3"
10843
10844 You can make this setting permanent like all C<o conf> settings with
10845 C<o conf commit>.
10846
10847 You will have to add ~/myperl/man to the MANPATH environment variable
10848 and also tell your perl programs to look into ~/myperl/lib, e.g. by
10849 including
10850
10851   use lib "$ENV{HOME}/myperl/lib";
10852
10853 or setting the PERL5LIB environment variable.
10854
10855 While we're speaking about $ENV{HOME}, it might be worth mentioning,
10856 that for Windows we use the File::HomeDir module that provides an
10857 equivalent to the concept of the home directory on Unix.
10858
10859 Another thing you should bear in mind is that the UNINST parameter can
10860 be dnagerous when you are installing into a private area because you
10861 might accidentally remove modules that other people depend on that are
10862 not using the private area.
10863
10864 =item 6)
10865
10866 How to get a package, unwrap it, and make a change before building it?
10867
10868 Have a look at the C<look> (!) command.
10869
10870 =item 7)
10871
10872 I installed a Bundle and had a couple of fails. When I
10873 retried, everything resolved nicely. Can this be fixed to work
10874 on first try?
10875
10876 The reason for this is that CPAN does not know the dependencies of all
10877 modules when it starts out. To decide about the additional items to
10878 install, it just uses data found in the META.yml file or the generated
10879 Makefile. An undetected missing piece breaks the process. But it may
10880 well be that your Bundle installs some prerequisite later than some
10881 depending item and thus your second try is able to resolve everything.
10882 Please note, CPAN.pm does not know the dependency tree in advance and
10883 cannot sort the queue of things to install in a topologically correct
10884 order. It resolves perfectly well IF all modules declare the
10885 prerequisites correctly with the PREREQ_PM attribute to MakeMaker or
10886 the C<requires> stanza of Module::Build. For bundles which fail and
10887 you need to install often, it is recommended to sort the Bundle
10888 definition file manually.
10889
10890 =item 8)
10891
10892 In our intranet we have many modules for internal use. How
10893 can I integrate these modules with CPAN.pm but without uploading
10894 the modules to CPAN?
10895
10896 Have a look at the CPAN::Site module.
10897
10898 =item 9)
10899
10900 When I run CPAN's shell, I get an error message about things in my
10901 /etc/inputrc (or ~/.inputrc) file.
10902
10903 These are readline issues and can only be fixed by studying readline
10904 configuration on your architecture and adjusting the referenced file
10905 accordingly. Please make a backup of the /etc/inputrc or ~/.inputrc
10906 and edit them. Quite often harmless changes like uppercasing or
10907 lowercasing some arguments solves the problem.
10908
10909 =item 10)
10910
10911 Some authors have strange characters in their names.
10912
10913 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
10914 expecting ISO-8859-1 charset, a converter can be activated by setting
10915 term_is_latin to a true value in your config file. One way of doing so
10916 would be
10917
10918     cpan> o conf term_is_latin 1
10919
10920 If other charset support is needed, please file a bugreport against
10921 CPAN.pm at rt.cpan.org and describe your needs. Maybe we can extend
10922 the support or maybe UTF-8 terminals become widely available.
10923
10924 =item 11)
10925
10926 When an install fails for some reason and then I correct the error
10927 condition and retry, CPAN.pm refuses to install the module, saying
10928 C<Already tried without success>.
10929
10930 Use the force pragma like so
10931
10932   force install Foo::Bar
10933
10934 Or you can use
10935
10936   look Foo::Bar
10937
10938 and then 'make install' directly in the subshell.
10939
10940 =item 12)
10941
10942 How do I install a "DEVELOPER RELEASE" of a module?
10943
10944 By default, CPAN will install the latest non-developer release of a
10945 module. If you want to install a dev release, you have to specify the
10946 partial path starting with the author id to the tarball you wish to
10947 install, like so:
10948
10949     cpan> install KWILLIAMS/Module-Build-0.27_07.tar.gz
10950
10951 Note that you can use the C<ls> command to get this path listed.
10952
10953 =item 13)
10954
10955 How do I install a module and all its dependencies from the commandline,
10956 without being prompted for anything, despite my CPAN configuration
10957 (or lack thereof)?
10958
10959 CPAN uses ExtUtils::MakeMaker's prompt() function to ask its questions, so
10960 if you set the PERL_MM_USE_DEFAULT environment variable, you shouldn't be
10961 asked any questions at all (assuming the modules you are installing are
10962 nice about obeying that variable as well):
10963
10964     % PERL_MM_USE_DEFAULT=1 perl -MCPAN -e 'install My::Module'
10965
10966 =item 14)
10967
10968 How do I create a Module::Build based Build.PL derived from an
10969 ExtUtils::MakeMaker focused Makefile.PL?
10970
10971 http://search.cpan.org/search?query=Module::Build::Convert
10972
10973 http://accognoscere.org/papers/perl-module-build-convert/module-build-convert.html
10974
10975 =item 15)
10976
10977 What's the best CPAN site for me?
10978
10979 The urllist config parameter is yours. You can add and remove sites at
10980 will. You should find out which sites have the best uptodateness,
10981 bandwidth, reliability, etc. and are topologically close to you. Some
10982 people prefer fast downloads, others uptodateness, others reliability.
10983 You decide which to try in which order.
10984
10985 Henk P. Penning maintains a site that collects data about CPAN sites:
10986
10987   http://www.cs.uu.nl/people/henkp/mirmon/cpan.html
10988
10989 =back
10990
10991 =head1 COMPATIBILITY
10992
10993 =head2 OLD PERL VERSIONS
10994
10995 CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted
10996 newer versions. It is getting more and more difficult to get the
10997 minimal prerequisites working on older perls. It is close to
10998 impossible to get the whole Bundle::CPAN working there. If you're in
10999 the position to have only these old versions, be advised that CPAN is
11000 designed to work fine without the Bundle::CPAN installed.
11001
11002 To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is
11003 compatible with ancient perls and that File::Temp is listed as a
11004 prerequisite but CPAN has reasonable workarounds if it is missing.
11005
11006 =head2 CPANPLUS
11007
11008 This module and its competitor, the CPANPLUS module, are both much
11009 cooler than the other. CPAN.pm is older. CPANPLUS was designed to be
11010 more modular but it was never tried to make it compatible with CPAN.pm.
11011
11012 =head1 SECURITY ADVICE
11013
11014 This software enables you to upgrade software on your computer and so
11015 is inherently dangerous because the newly installed software may
11016 contain bugs and may alter the way your computer works or even make it
11017 unusable. Please consider backing up your data before every upgrade.
11018
11019 =head1 BUGS
11020
11021 Please report bugs via http://rt.cpan.org/
11022
11023 Before submitting a bug, please make sure that the traditional method
11024 of building a Perl module package from a shell by following the
11025 installation instructions of that package still works in your
11026 environment.
11027
11028 =head1 AUTHOR
11029
11030 Andreas Koenig C<< <andk@cpan.org> >>
11031
11032 =head1 LICENSE
11033
11034 This program is free software; you can redistribute it and/or
11035 modify it under the same terms as Perl itself.
11036
11037 See L<http://www.perl.com/perl/misc/Artistic.html>
11038
11039 =head1 TRANSLATIONS
11040
11041 Kawai,Takanori provides a Japanese translation of this manpage at
11042 http://homepage3.nifty.com/hippo2000/perltips/CPAN.htm
11043
11044 =head1 SEE ALSO
11045
11046 cpan(1), CPAN::Nox(3pm), CPAN::Version(3pm)
11047
11048 =cut
11049
11050