lib/CPAN.pm

   1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
   2 use strict;
   3 package CPAN;
   4 $CPAN::VERSION = '1.88_62';
   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
  45 END { $CPAN::End++; &cleanup; }
  46
  47 $CPAN::Signal ||= 0;
  48 $CPAN::Frontend ||= "CPAN::Shell";
  49 unless (@CPAN::Defaultsites){
  50     @CPAN::Defaultsites = map {
  51         CPAN::URL->new(TEXT => $_, FROM => "DEF")
  52     }
  53         "http://www.perl.org/CPAN/",
  54             "ftp://ftp.perl.org/pub/CPAN/";
  55 }
  56 # $CPAN::iCwd (i for initial) is going to be initialized during find_perl
  57 $CPAN::Perl ||= CPAN::find_perl();
  58 $CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?";
  59 $CPAN::Defaultrecent ||= "http://search.cpan.org/recent";
  60
  61 # our globals are getting a mess
  62 use vars qw(
  63             $AUTOLOAD
  64             $Be_Silent
  65             $CONFIG_DIRTY
  66             $DEBUG
  67             $Defaultdocs
  68             $Defaultrecent
  69             $Frontend
  70             $GOTOSHELL
  71             $HAS_USABLE
  72             $Have_warned
  73             $META
  74             $RUN_DEGRADED
  75             $Signal
  76             $Suppress_readline
  77             $VERSION
  78             $autoload_recursion
  79             $term
  80             @Defaultsites
  81             @EXPORT
  82            );
  83
  84 @CPAN::ISA = qw(CPAN::Debug Exporter);
  85
  86 # note that these functions live in CPAN::Shell and get executed via
  87 # AUTOLOAD when called directly
  88 @EXPORT = qw(
  89              autobundle
  90              bundle
  91              clean
  92              cvs_import
  93              expand
  94              force
  95              get
  96              install
  97              install_tested
  98              make
  99              mkmyconfig
 100              notest
 101              perldoc
 102              readme
 103              recent
 104              recompile
 105              report
 106              shell
 107              test
 108              upgrade
 109             );
 110
 111 sub soft_chdir_with_alternatives ($);
 112
 113 {
 114     $autoload_recursion ||= 0;
 115
 116     #-> sub CPAN::AUTOLOAD ;
 117     sub AUTOLOAD {
 118         $autoload_recursion++;
 119         my($l) = $AUTOLOAD;
 120         $l =~ s/.*:://;
 121         if ($CPAN::Signal) {
 122             warn "Refusing to autoload '$l' while signal pending";
 123             $autoload_recursion--;
 124             return;
 125         }
 126         if ($autoload_recursion > 1) {
 127             my $fullcommand = join " ", map { "'$_'" } $l, @_;
 128             warn "Refusing to autoload $fullcommand in recursion\n";
 129             $autoload_recursion--;
 130             return;
 131         }
 132         my(%export);
 133         @export{@EXPORT} = '';
 134         CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 135         if (exists $export{$l}){
 136             CPAN::Shell->$l(@_);
 137         } else {
 138             die(qq{Unknown CPAN command "$AUTOLOAD". }.
 139                 qq{Type ? for help.\n});
 140         }
 141         $autoload_recursion--;
 142     }
 143 }
 144
 145 #-> sub CPAN::shell ;
 146 sub shell {
 147     my($self) = @_;
 148     $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
 149     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 150
 151     my $oprompt = shift || CPAN::Prompt->new;
 152     my $prompt = $oprompt;
 153     my $commandline = shift || "";
 154     $CPAN::CurrentCommandId ||= 1;
 155
 156     local($^W) = 1;
 157     unless ($Suppress_readline) {
 158         require Term::ReadLine;
 159         if (! $term
 160             or
 161             $term->ReadLine eq "Term::ReadLine::Stub"
 162            ) {
 163             $term = Term::ReadLine->new('CPAN Monitor');
 164         }
 165         if ($term->ReadLine eq "Term::ReadLine::Gnu") {
 166             my $attribs = $term->Attribs;
 167              $attribs->{attempted_completion_function} = sub {
 168                  &CPAN::Complete::gnu_cpl;
 169              }
 170         } else {
 171             $readline::rl_completion_function =
 172                 $readline::rl_completion_function = 'CPAN::Complete::cpl';
 173         }
 174         if (my $histfile = $CPAN::Config->{'histfile'}) {{
 175             unless ($term->can("AddHistory")) {
 176                 $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
 177                 last;
 178             }
 179             my($fh) = FileHandle->new;
 180             open $fh, "<$histfile" or last;
 181             local $/ = "\n";
 182             while (<$fh>) {
 183                 chomp;
 184                 $term->AddHistory($_);
 185             }
 186             close $fh;
 187         }}
 188         for ($CPAN::Config->{term_ornaments}) { # alias
 189             local $Term::ReadLine::termcap_nowarn = 1;
 190             $term->ornaments($_) if defined;
 191         }
 192         # $term->OUT is autoflushed anyway
 193         my $odef = select STDERR;
 194         $| = 1;
 195         select STDOUT;
 196         $| = 1;
 197         select $odef;
 198     }
 199
 200     # no strict; # I do not recall why no strict was here (2000-09-03)
 201     $META->checklock();
 202     my @cwd = grep { defined $_ and length $_ }
 203         CPAN::anycwd(),
 204               File::Spec->can("tmpdir") ? File::Spec->tmpdir() : (),
 205                     File::Spec->rootdir();
 206     my $try_detect_readline;
 207     $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
 208     my $rl_avail = $Suppress_readline ? "suppressed" :
 209         ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
 210             "available (try 'install Bundle::CPAN')";
 211
 212     unless ($CPAN::Config->{'inhibit_startup_message'}){
 213         $CPAN::Frontend->myprint(
 214                                  sprintf qq{
 215 cpan shell -- CPAN exploration and modules installation (v%s)
 216 ReadLine support %s
 217
 218 },
 219                                  $CPAN::VERSION,
 220                                  $rl_avail
 221                                 )
 222     }
 223     my($continuation) = "";
 224     my $last_term_ornaments;
 225   SHELLCOMMAND: while () {
 226         if ($Suppress_readline) {
 227             print $prompt;
 228             last SHELLCOMMAND unless defined ($_ = <> );
 229             chomp;
 230         } else {
 231             last SHELLCOMMAND unless
 232                 defined ($_ = $term->readline($prompt, $commandline));
 233         }
 234         $_ = "$continuation$_" if $continuation;
 235         s/^\s+//;
 236         next SHELLCOMMAND if /^$/;
 237         $_ = 'h' if /^\s*\?/;
 238         if (/^(?:q(?:uit)?|bye|exit)$/i) {
 239             last SHELLCOMMAND;
 240         } elsif (s/\\$//s) {
 241             chomp;
 242             $continuation = $_;
 243             $prompt = "    > ";
 244         } elsif (/^\!/) {
 245             s/^\!//;
 246             my($eval) = $_;
 247             package CPAN::Eval;
 248             use strict;
 249             use vars qw($import_done);
 250             CPAN->import(':DEFAULT') unless $import_done++;
 251             CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
 252             eval($eval);
 253             warn $@ if $@;
 254             $continuation = "";
 255             $prompt = $oprompt;
 256         } elsif (/./) {
 257             my(@line);
 258             eval { @line = Text::ParseWords::shellwords($_) };
 259             warn($@), next SHELLCOMMAND if $@;
 260             warn("Text::Parsewords could not parse the line [$_]"),
 261                 next SHELLCOMMAND unless @line;
 262             $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
 263             my $command = shift @line;
 264             eval { CPAN::Shell->$command(@line) };
 265             if ($@){
 266                 require Carp;
 267                 Carp::cluck($@);
 268             }
 269             if ($command =~ /^(make|test|install|force|notest|clean|report|upgrade)$/) {
 270                 CPAN::Shell->failed($CPAN::CurrentCommandId,1);
 271             }
 272             soft_chdir_with_alternatives(\@cwd);
 273             $CPAN::Frontend->myprint("\n");
 274             $continuation = "";
 275             $CPAN::CurrentCommandId++;
 276             $prompt = $oprompt;
 277         }
 278     } continue {
 279       $commandline = ""; # I do want to be able to pass a default to
 280                          # shell, but on the second command I see no
 281                          # use in that
 282       $Signal=0;
 283       CPAN::Queue->nullify_queue;
 284       if ($try_detect_readline) {
 285         if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
 286             ||
 287             $CPAN::META->has_inst("Term::ReadLine::Perl")
 288            ) {
 289             delete $INC{"Term/ReadLine.pm"};
 290             my $redef = 0;
 291             local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
 292             require Term::ReadLine;
 293             $CPAN::Frontend->myprint("\n$redef subroutines in ".
 294                                      "Term::ReadLine redefined\n");
 295             $GOTOSHELL = 1;
 296         }
 297       }
 298       if ($term and $term->can("ornaments")) {
 299           for ($CPAN::Config->{term_ornaments}) { # alias
 300               if (defined $_) {
 301                   if (not defined $last_term_ornaments
 302                       or $_ != $last_term_ornaments
 303                      ) {
 304                       local $Term::ReadLine::termcap_nowarn = 1;
 305                       $term->ornaments($_);
 306                       $last_term_ornaments = $_;
 307                   }
 308               } else {
 309                   undef $last_term_ornaments;
 310               }
 311           }
 312       }
 313       for my $class (qw(Module Distribution)) {
 314           # again unsafe meta access?
 315           for my $dm (keys %{$CPAN::META->{readwrite}{"CPAN::$class"}}) {
 316               next unless $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
 317               CPAN->debug("BUG: $class '$dm' was in command state, resetting");
 318               delete $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
 319           }
 320       }
 321       if ($GOTOSHELL) {
 322           $GOTOSHELL = 0; # not too often
 323           $META->savehist if $CPAN::term && $CPAN::term->can("GetHistory");
 324           @_ = ($oprompt,"");
 325           goto &shell;
 326       }
 327     }
 328     soft_chdir_with_alternatives(\@cwd);
 329 }
 330
 331 sub soft_chdir_with_alternatives ($) {
 332     my($cwd) = @_;
 333     unless (@$cwd) {
 334         my $root = File::Spec->rootdir();
 335         $CPAN::Frontend->mywarn(qq{Warning: no good directory to chdir to!
 336 Trying '$root' as temporary haven.
 337 });
 338         push @$cwd, $root;
 339     }
 340     while () {
 341         if (chdir $cwd->[0]) {
 342             return;
 343         } else {
 344             if (@$cwd>1) {
 345                 $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $!
 346 Trying to chdir to "$cwd->[1]" instead.
 347 });
 348                 shift @$cwd;
 349             } else {
 350                 $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!});
 351             }
 352         }
 353     }
 354 }
 355
 356 sub _yaml_module {
 357     my $yaml_module = $CPAN::Config->{yaml_module} || "YAML";
 358     if (
 359         $yaml_module ne "YAML"
 360         &&
 361         !$CPAN::META->has_inst($yaml_module)
 362        ) {
 363         # $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back to 'YAML'\n");
 364         $yaml_module = "YAML";
 365     }
 366     return $yaml_module;
 367 }
 368
 369 # CPAN::_yaml_loadfile
 370 sub _yaml_loadfile {
 371     my($self,$local_file) = @_;
 372     return +[] unless -s $local_file;
 373     my $yaml_module = $self->_yaml_module;
 374     if ($CPAN::META->has_inst($yaml_module)) {
 375         my $code = UNIVERSAL::can($yaml_module, "LoadFile");
 376         my @yaml;
 377         eval { @yaml = $code->($local_file); };
 378         if ($@) {
 379             $CPAN::Frontend->mydie("Alert: While trying to parse YAML file\n".
 380                                    "  $local_file\n".
 381                                    "with $yaml_module the following error was encountered:\n".
 382                                    "  $@\n"
 383                                   );
 384         }
 385         return \@yaml;
 386     } else {
 387         $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot parse '$local_file'\n");
 388     }
 389     return +[];
 390 }
 391
 392 # CPAN::_yaml_dumpfile
 393 sub _yaml_dumpfile {
 394     my($self,$to_local_file,@what) = @_;
 395     my $yaml_module = $self->_yaml_module;
 396     if ($CPAN::META->has_inst($yaml_module)) {
 397         if (UNIVERSAL::isa($to_local_file, "FileHandle")) {
 398             my $code = UNIVERSAL::can($yaml_module, "Dump");
 399             eval { print $to_local_file $code->(@what) };
 400         } else {
 401             my $code = UNIVERSAL::can($yaml_module, "DumpFile");
 402             eval { $code->($to_local_file,@what); };
 403         }
 404         if ($@) {
 405             $CPAN::Frontend->mydie("Alert: While trying to dump YAML file\n".
 406                                    "  $to_local_file\n".
 407                                    "with $yaml_module the following error was encountered:\n".
 408                                    "  $@\n"
 409                                   );
 410         }
 411     } else {
 412         $CPAN::Frontend->myprint("Note (usually harmless): '$yaml_module' not installed, not dumping to '$to_local_file'\n");
 413     }
 414 }
 415
 416 package CPAN::CacheMgr;
 417 use strict;
 418 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
 419 use File::Find;
 420
 421 package CPAN::FTP;
 422 use strict;
 423 use Fcntl qw(:flock);
 424 use vars qw($Ua $Thesite $ThesiteURL $Themethod);
 425 @CPAN::FTP::ISA = qw(CPAN::Debug);
 426
 427 package CPAN::LWP::UserAgent;
 428 use strict;
 429 use vars qw(@ISA $USER $PASSWD $SETUPDONE);
 430 # we delay requiring LWP::UserAgent and setting up inheritance until we need it
 431
 432 package CPAN::Complete;
 433 use strict;
 434 @CPAN::Complete::ISA = qw(CPAN::Debug);
 435 # Q: where is the "How do I add a new command" HOWTO?
 436 # A: svn diff -r 1048:1049 where andk added the report command
 437 @CPAN::Complete::COMMANDS = sort qw(
 438                                     ! a b d h i m o q r u
 439                                     autobundle
 440                                     clean
 441                                     cvs_import
 442                                     dump
 443                                     force
 444                                     hosts
 445                                     install
 446                                     install_tested
 447                                     look
 448                                     ls
 449                                     make
 450                                     mkmyconfig
 451                                     notest
 452                                     perldoc
 453                                     readme
 454                                     recent
 455                                     recompile
 456                                     reload
 457                                     report
 458                                     scripts
 459                                     test
 460                                     upgrade
 461 );
 462
 463 package CPAN::Index;
 464 use strict;
 465 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED);
 466 @CPAN::Index::ISA = qw(CPAN::Debug);
 467 $LAST_TIME ||= 0;
 468 $DATE_OF_03 ||= 0;
 469 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
 470 sub PROTOCOL { 2.0 }
 471
 472 package CPAN::InfoObj;
 473 use strict;
 474 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
 475
 476 package CPAN::Author;
 477 use strict;
 478 @CPAN::Author::ISA = qw(CPAN::InfoObj);
 479
 480 package CPAN::Distribution;
 481 use strict;
 482 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
 483
 484 package CPAN::Bundle;
 485 use strict;
 486 @CPAN::Bundle::ISA = qw(CPAN::Module);
 487
 488 package CPAN::Module;
 489 use strict;
 490 @CPAN::Module::ISA = qw(CPAN::InfoObj);
 491
 492 package CPAN::Exception::RecursiveDependency;
 493 use strict;
 494 use overload '""' => "as_string";
 495
 496 sub new {
 497     my($class) = shift;
 498     my($deps) = shift;
 499     my @deps;
 500     my %seen;
 501     for my $dep (@$deps) {
 502         push @deps, $dep;
 503         last if $seen{$dep}++;
 504     }
 505     bless { deps => \@deps }, $class;
 506 }
 507
 508 sub as_string {
 509     my($self) = shift;
 510     "\nRecursive dependency detected:\n    " .
 511         join("\n => ", @{$self->{deps}}) .
 512             ".\nCannot continue.\n";
 513 }
 514
 515 package CPAN::Prompt; use overload '""' => "as_string";
 516 use vars qw($prompt);
 517 $prompt = "cpan> ";
 518 $CPAN::CurrentCommandId ||= 0;
 519 sub new {
 520     bless {}, shift;
 521 }
 522 sub as_string {
 523     my $word = "cpan";
 524     unless ($CPAN::META->{LOCK}) {
 525         $word = "nolock_cpan";
 526     }
 527     if ($CPAN::Config->{commandnumber_in_prompt}) {
 528         sprintf "$word\[%d]> ", $CPAN::CurrentCommandId;
 529     } else {
 530         "$word> ";
 531     }
 532 }
 533
 534 package CPAN::URL; use overload '""' => "as_string", fallback => 1;
 535 # accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist),
 536 # planned are things like age or quality
 537 sub new {
 538     my($class,%args) = @_;
 539     bless {
 540            %args
 541           }, $class;
 542 }
 543 sub as_string {
 544     my($self) = @_;
 545     $self->text;
 546 }
 547 sub text {
 548     my($self,$set) = @_;
 549     if (defined $set) {
 550         $self->{TEXT} = $set;
 551     }
 552     $self->{TEXT};
 553 }
 554
 555 package CPAN::Distrostatus;
 556 use overload '""' => "as_string",
 557     fallback => 1;
 558 sub new {
 559     my($class,$arg) = @_;
 560     bless {
 561            TEXT => $arg,
 562            FAILED => substr($arg,0,2) eq "NO",
 563            COMMANDID => $CPAN::CurrentCommandId,
 564           }, $class;
 565 }
 566 sub commandid { shift->{COMMANDID} }
 567 sub failed { shift->{FAILED} }
 568 sub text {
 569     my($self,$set) = @_;
 570     if (defined $set) {
 571         $self->{TEXT} = $set;
 572     }
 573     $self->{TEXT};
 574 }
 575 sub as_string {
 576     my($self) = @_;
 577     $self->text;
 578 }
 579
 580 package CPAN::Shell;
 581 use strict;
 582 use vars qw(
 583             $ADVANCED_QUERY
 584             $AUTOLOAD
 585             $COLOR_REGISTERED
 586             $autoload_recursion
 587             $reload
 588             @ISA
 589            );
 590 @CPAN::Shell::ISA = qw(CPAN::Debug);
 591 $COLOR_REGISTERED ||= 0;
 592
 593 {
 594     $autoload_recursion   ||= 0;
 595
 596     #-> sub CPAN::Shell::AUTOLOAD ;
 597     sub AUTOLOAD {
 598         $autoload_recursion++;
 599         my($l) = $AUTOLOAD;
 600         my $class = shift(@_);
 601         # warn "autoload[$l] class[$class]";
 602         $l =~ s/.*:://;
 603         if ($CPAN::Signal) {
 604             warn "Refusing to autoload '$l' while signal pending";
 605             $autoload_recursion--;
 606             return;
 607         }
 608         if ($autoload_recursion > 1) {
 609             my $fullcommand = join " ", map { "'$_'" } $l, @_;
 610             warn "Refusing to autoload $fullcommand in recursion\n";
 611             $autoload_recursion--;
 612             return;
 613         }
 614         if ($l =~ /^w/) {
 615             # XXX needs to be reconsidered
 616             if ($CPAN::META->has_inst('CPAN::WAIT')) {
 617                 CPAN::WAIT->$l(@_);
 618             } else {
 619                 $CPAN::Frontend->mywarn(qq{
 620 Commands starting with "w" require CPAN::WAIT to be installed.
 621 Please consider installing CPAN::WAIT to use the fulltext index.
 622 For this you just need to type
 623     install CPAN::WAIT
 624 });
 625             }
 626         } else {
 627             $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }.
 628                                     qq{Type ? for help.
 629 });
 630         }
 631         $autoload_recursion--;
 632     }
 633 }
 634
 635 package CPAN;
 636 use strict;
 637
 638 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
 639
 640 # from here on only subs.
 641 ################################################################################
 642
 643 sub _perl_fingerprint {
 644     my($self,$other_fingerprint) = @_;
 645     my $dll = eval {OS2::DLLname()};
 646     my $mtime_dll = 0;
 647     if (defined $dll) {
 648         $mtime_dll = (-f $dll ? (stat(_))[9] : '-1');
 649     }
 650     my $this_fingerprint = {
 651                             '$^X' => $^X,
 652                             sitearchexp => $Config::Config{sitearchexp},
 653                             'mtime_$^X' => (stat $^X)[9],
 654                             'mtime_dll' => $mtime_dll,
 655                            };
 656     if ($other_fingerprint) {
 657         if (exists $other_fingerprint->{'stat($^X)'}) { # repair fp from rev. 1.88_57
 658             $other_fingerprint->{'mtime_$^X'} = $other_fingerprint->{'stat($^X)'}[9];
 659         }
 660         # mandatory keys since 1.88_57
 661         for my $key (qw($^X sitearchexp mtime_dll mtime_$^X)) {
 662             return unless $other_fingerprint->{$key} eq $this_fingerprint->{$key};
 663         }
 664         return 1;
 665     } else {
 666         return $this_fingerprint;
 667     }
 668 }
 669
 670 sub suggest_myconfig () {
 671   SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) {
 672         $CPAN::Frontend->myprint("You don't seem to have a user ".
 673                                  "configuration (MyConfig.pm) yet.\n");
 674         my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ".
 675                                               "user configuration now? (Y/n)",
 676                                               "yes");
 677         if($new =~ m{^y}i) {
 678             CPAN::Shell->mkmyconfig();
 679             return &checklock;
 680         } else {
 681             $CPAN::Frontend->mydie("OK, giving up.");
 682         }
 683     }
 684 }
 685
 686 #-> sub CPAN::all_objects ;
 687 sub all_objects {
 688     my($mgr,$class) = @_;
 689     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 690     CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
 691     CPAN::Index->reload;
 692     values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
 693 }
 694
 695 # Called by shell, not in batch mode. In batch mode I see no risk in
 696 # having many processes updating something as installations are
 697 # continually checked at runtime. In shell mode I suspect it is
 698 # unintentional to open more than one shell at a time
 699
 700 #-> sub CPAN::checklock ;
 701 sub checklock {
 702     my($self) = @_;
 703     my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
 704     if (-f $lockfile && -M _ > 0) {
 705         my $fh = FileHandle->new($lockfile) or
 706             $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
 707         my $otherpid  = <$fh>;
 708         my $otherhost = <$fh>;
 709         $fh->close;
 710         if (defined $otherpid && $otherpid) {
 711             chomp $otherpid;
 712         }
 713         if (defined $otherhost && $otherhost) {
 714             chomp $otherhost;
 715         }
 716         my $thishost  = hostname();
 717         if (defined $otherhost && defined $thishost &&
 718             $otherhost ne '' && $thishost ne '' &&
 719             $otherhost ne $thishost) {
 720             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
 721                                            "reports other host $otherhost and other ".
 722                                            "process $otherpid.\n".
 723                                            "Cannot proceed.\n"));
 724         } elsif ($RUN_DEGRADED) {
 725             $CPAN::Frontend->mywarn("Running in degraded mode (experimental)\n");
 726         } elsif (defined $otherpid && $otherpid) {
 727             return if $$ == $otherpid; # should never happen
 728             $CPAN::Frontend->mywarn(
 729                                     qq{
 730 There seems to be running another CPAN process (pid $otherpid).  Contacting...
 731 });
 732             if (kill 0, $otherpid) {
 733                 $CPAN::Frontend->mywarn(qq{Other job is running.\n});
 734                 my($ans) =
 735                     CPAN::Shell::colorable_makemaker_prompt
 736                         (qq{Shall I try to run in degraded }.
 737                          qq{mode? (Y/n)},"y");
 738                 if ($ans =~ /^y/i) {
 739                     $CPAN::Frontend->mywarn("Running in degraded mode (experimental).
 740 Please report if something unexpected happens\n");
 741                     $RUN_DEGRADED = 1;
 742                     for ($CPAN::Config) {
 743                         $_->{build_dir_reuse} = 0;
 744                         $_->{commandnumber_in_prompt} = 0;
 745                         $_->{histfile} = "";
 746                         $_->{cache_metadata} = 0;
 747                     }
 748                 } else {
 749                     $CPAN::Frontend->mydie("
 750 You may want to kill the other job and delete the lockfile. On UNIX try:
 751     kill $otherpid
 752     rm $lockfile
 753 ");
 754                 }
 755             } elsif (-w $lockfile) {
 756                 my($ans) =
 757                     CPAN::Shell::colorable_makemaker_prompt
 758                         (qq{Other job not responding. Shall I overwrite }.
 759                          qq{the lockfile '$lockfile'? (Y/n)},"y");
 760                 $CPAN::Frontend->myexit("Ok, bye\n")
 761                     unless $ans =~ /^y/i;
 762             } else {
 763                 Carp::croak(
 764                             qq{Lockfile '$lockfile' not writeable by you. }.
 765                             qq{Cannot proceed.\n}.
 766                             qq{    On UNIX try:\n}.
 767                             qq{    rm '$lockfile'\n}.
 768                             qq{  and then rerun us.\n}
 769                            );
 770             }
 771         } else {
 772             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Found invalid lockfile ".
 773                                            "'$lockfile', please remove. Cannot proceed.\n"));
 774         }
 775     }
 776     my $dotcpan = $CPAN::Config->{cpan_home};
 777     eval { File::Path::mkpath($dotcpan);};
 778     if ($@) {
 779         # A special case at least for Jarkko.
 780         my $firsterror = $@;
 781         my $seconderror;
 782         my $symlinkcpan;
 783         if (-l $dotcpan) {
 784             $symlinkcpan = readlink $dotcpan;
 785             die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
 786             eval { File::Path::mkpath($symlinkcpan); };
 787             if ($@) {
 788                 $seconderror = $@;
 789             } else {
 790                 $CPAN::Frontend->mywarn(qq{
 791 Working directory $symlinkcpan created.
 792 });
 793             }
 794         }
 795         unless (-d $dotcpan) {
 796             my $mess = qq{
 797 Your configuration suggests "$dotcpan" as your
 798 CPAN.pm working directory. I could not create this directory due
 799 to this error: $firsterror\n};
 800             $mess .= qq{
 801 As "$dotcpan" is a symlink to "$symlinkcpan",
 802 I tried to create that, but I failed with this error: $seconderror
 803 } if $seconderror;
 804             $mess .= qq{
 805 Please make sure the directory exists and is writable.
 806 };
 807             $CPAN::Frontend->myprint($mess);
 808             return suggest_myconfig;
 809         }
 810     } # $@ after eval mkpath $dotcpan
 811     if (0) { # to test what happens when a race condition occurs
 812         for (reverse 1..10) {
 813             print $_, "\n";
 814             sleep 1;
 815         }
 816     }
 817     # locking
 818     if (!$RUN_DEGRADED && !$self->{LOCKFH}) {
 819         my $fh;
 820         unless ($fh = FileHandle->new("+>>$lockfile")) {
 821             if ($! =~ /Permission/) {
 822                 $CPAN::Frontend->myprint(qq{
 823
 824 Your configuration suggests that CPAN.pm should use a working
 825 directory of
 826     $CPAN::Config->{cpan_home}
 827 Unfortunately we could not create the lock file
 828     $lockfile
 829 due to permission problems.
 830
 831 Please make sure that the configuration variable
 832     \$CPAN::Config->{cpan_home}
 833 points to a directory where you can write a .lock file. You can set
 834 this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
 835 \@INC path;
 836 });
 837                 return suggest_myconfig;
 838             }
 839         }
 840         my $sleep = 1;
 841         while (!flock $fh, LOCK_EX|LOCK_NB) {
 842             if ($sleep>10) {
 843                 $CPAN::Frontend->mydie("Giving up\n");
 844             }
 845             $CPAN::Frontend->mysleep($sleep++);
 846             $CPAN::Frontend->mywarn("Could not lock lockfile with flock: $!; retrying\n");
 847         }
 848
 849         seek $fh, 0, 0;
 850         truncate $fh, 0;
 851         $fh->print($$, "\n");
 852         $fh->print(hostname(), "\n");
 853         $self->{LOCK} = $lockfile;
 854         $self->{LOCKFH} = $fh;
 855     }
 856     $SIG{TERM} = sub {
 857         my $sig = shift;
 858         &cleanup;
 859         $CPAN::Frontend->mydie("Got SIG$sig, leaving");
 860     };
 861     $SIG{INT} = sub {
 862       # no blocks!!!
 863         my $sig = shift;
 864         &cleanup if $Signal;
 865         die "Got yet another signal" if $Signal > 1;
 866         $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal;
 867         $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n");
 868         $Signal++;
 869     };
 870
 871 #       From: Larry Wall <larry@wall.org>
 872 #       Subject: Re: deprecating SIGDIE
 873 #       To: perl5-porters@perl.org
 874 #       Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
 875 #
 876 #       The original intent of __DIE__ was only to allow you to substitute one
 877 #       kind of death for another on an application-wide basis without respect
 878 #       to whether you were in an eval or not.  As a global backstop, it should
 879 #       not be used any more lightly (or any more heavily :-) than class
 880 #       UNIVERSAL.  Any attempt to build a general exception model on it should
 881 #       be politely squashed.  Any bug that causes every eval {} to have to be
 882 #       modified should be not so politely squashed.
 883 #
 884 #       Those are my current opinions.  It is also my optinion that polite
 885 #       arguments degenerate to personal arguments far too frequently, and that
 886 #       when they do, it's because both people wanted it to, or at least didn't
 887 #       sufficiently want it not to.
 888 #
 889 #       Larry
 890
 891     # global backstop to cleanup if we should really die
 892     $SIG{__DIE__} = \&cleanup;
 893     $self->debug("Signal handler set.") if $CPAN::DEBUG;
 894 }
 895
 896 #-> sub CPAN::DESTROY ;
 897 sub DESTROY {
 898     &cleanup; # need an eval?
 899 }
 900
 901 #-> sub CPAN::anycwd ;
 902 sub anycwd () {
 903     my $getcwd;
 904     $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
 905     CPAN->$getcwd();
 906 }
 907
 908 #-> sub CPAN::cwd ;
 909 sub cwd {Cwd::cwd();}
 910
 911 #-> sub CPAN::getcwd ;
 912 sub getcwd {Cwd::getcwd();}
 913
 914 #-> sub CPAN::fastcwd ;
 915 sub fastcwd {Cwd::fastcwd();}
 916
 917 #-> sub CPAN::backtickcwd ;
 918 sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
 919
 920 #-> sub CPAN::find_perl ;
 921 sub find_perl {
 922     my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
 923     my $pwd  = $CPAN::iCwd = CPAN::anycwd();
 924     my $candidate = File::Spec->catfile($pwd,$^X);
 925     $perl ||= $candidate if MM->maybe_command($candidate);
 926
 927     unless ($perl) {
 928         my ($component,$perl_name);
 929       DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
 930             PATH_COMPONENT: foreach $component (File::Spec->path(),
 931                                                 $Config::Config{'binexp'}) {
 932                   next unless defined($component) && $component;
 933                   my($abs) = File::Spec->catfile($component,$perl_name);
 934                   if (MM->maybe_command($abs)) {
 935                       $perl = $abs;
 936                       last DIST_PERLNAME;
 937                   }
 938               }
 939           }
 940     }
 941
 942     return $perl;
 943 }
 944
 945
 946 #-> sub CPAN::exists ;
 947 sub exists {
 948     my($mgr,$class,$id) = @_;
 949     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 950     CPAN::Index->reload;
 951     ### Carp::croak "exists called without class argument" unless $class;
 952     $id ||= "";
 953     $id =~ s/:+/::/g if $class eq "CPAN::Module";
 954     exists $META->{readonly}{$class}{$id} or
 955         exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
 956 }
 957
 958 #-> sub CPAN::delete ;
 959 sub delete {
 960   my($mgr,$class,$id) = @_;
 961   delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
 962   delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
 963 }
 964
 965 #-> sub CPAN::has_usable
 966 # has_inst is sometimes too optimistic, we should replace it with this
 967 # has_usable whenever a case is given
 968 sub has_usable {
 969     my($self,$mod,$message) = @_;
 970     return 1 if $HAS_USABLE->{$mod};
 971     my $has_inst = $self->has_inst($mod,$message);
 972     return unless $has_inst;
 973     my $usable;
 974     $usable = {
 975                LWP => [ # we frequently had "Can't locate object
 976                         # method "new" via package "LWP::UserAgent" at
 977                         # (eval 69) line 2006
 978                        sub {require LWP},
 979                        sub {require LWP::UserAgent},
 980                        sub {require HTTP::Request},
 981                        sub {require URI::URL},
 982                       ],
 983                'Net::FTP' => [
 984                             sub {require Net::FTP},
 985                             sub {require Net::Config},
 986                            ],
 987                'File::HomeDir' => [
 988                                    sub {require File::HomeDir;
 989                                         unless (File::HomeDir::->VERSION >= 0.52){
 990                                             for ("Will not use File::HomeDir, need 0.52\n") {
 991                                                 $CPAN::Frontend->mywarn($_);
 992                                                 die $_;
 993                                             }
 994                                         }
 995                                     },
 996                                   ],
 997               };
 998     if ($usable->{$mod}) {
 999         for my $c (0..$#{$usable->{$mod}}) {
1000             my $code = $usable->{$mod}[$c];
1001             my $ret = eval { &$code() };
1002             $ret = "" unless defined $ret;
1003             if ($@) {
1004                 # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
1005                 return;
1006             }
1007         }
1008     }
1009     return $HAS_USABLE->{$mod} = 1;
1010 }
1011
1012 #-> sub CPAN::has_inst
1013 sub has_inst {
1014     my($self,$mod,$message) = @_;
1015     Carp::croak("CPAN->has_inst() called without an argument")
1016         unless defined $mod;
1017     my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
1018         keys %{$CPAN::Config->{dontload_hash}||{}},
1019             @{$CPAN::Config->{dontload_list}||[]};
1020     if (defined $message && $message eq "no"  # afair only used by Nox
1021         ||
1022         $dont{$mod}
1023        ) {
1024       $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
1025       return 0;
1026     }
1027     my $file = $mod;
1028     my $obj;
1029     $file =~ s|::|/|g;
1030     $file .= ".pm";
1031     if ($INC{$file}) {
1032         # checking %INC is wrong, because $INC{LWP} may be true
1033         # although $INC{"URI/URL.pm"} may have failed. But as
1034         # I really want to say "bla loaded OK", I have to somehow
1035         # cache results.
1036         ### warn "$file in %INC"; #debug
1037         return 1;
1038     } elsif (eval { require $file }) {
1039         # eval is good: if we haven't yet read the database it's
1040         # perfect and if we have installed the module in the meantime,
1041         # it tries again. The second require is only a NOOP returning
1042         # 1 if we had success, otherwise it's retrying
1043
1044         my $v = eval "\$$mod\::VERSION";
1045         $v = $v ? " (v$v)" : "";
1046         $CPAN::Frontend->myprint("CPAN: $mod loaded ok$v\n");
1047         if ($mod eq "CPAN::WAIT") {
1048             push @CPAN::Shell::ISA, 'CPAN::WAIT';
1049         }
1050         return 1;
1051     } elsif ($mod eq "Net::FTP") {
1052         $CPAN::Frontend->mywarn(qq{
1053   Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
1054   if you just type
1055       install Bundle::libnet
1056
1057 }) unless $Have_warned->{"Net::FTP"}++;
1058         $CPAN::Frontend->mysleep(3);
1059     } elsif ($mod eq "Digest::SHA"){
1060         if ($Have_warned->{"Digest::SHA"}++) {
1061             $CPAN::Frontend->myprint(qq{CPAN: checksum security checks disabled}.
1062                                      qq{because Digest::SHA not installed.\n});
1063         } else {
1064             $CPAN::Frontend->mywarn(qq{
1065   CPAN: checksum security checks disabled because Digest::SHA not installed.
1066   Please consider installing the Digest::SHA module.
1067
1068 });
1069             $CPAN::Frontend->mysleep(2);
1070         }
1071     } elsif ($mod eq "Module::Signature"){
1072         if (not $CPAN::Config->{check_sigs}) {
1073             # they do not want us:-(
1074         } elsif (not $Have_warned->{"Module::Signature"}++) {
1075             # No point in complaining unless the user can
1076             # reasonably install and use it.
1077             if (eval { require Crypt::OpenPGP; 1 } ||
1078                 (
1079                  defined $CPAN::Config->{'gpg'}
1080                  &&
1081                  $CPAN::Config->{'gpg'} =~ /\S/
1082                 )
1083                ) {
1084                 $CPAN::Frontend->mywarn(qq{
1085   CPAN: Module::Signature security checks disabled because Module::Signature
1086   not installed.  Please consider installing the Module::Signature module.
1087   You may also need to be able to connect over the Internet to the public
1088   keyservers like pgp.mit.edu (port 11371).
1089
1090 });
1091                 $CPAN::Frontend->mysleep(2);
1092             }
1093         }
1094     } else {
1095         delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
1096     }
1097     return 0;
1098 }
1099
1100 #-> sub CPAN::instance ;
1101 sub instance {
1102     my($mgr,$class,$id) = @_;
1103     CPAN::Index->reload;
1104     $id ||= "";
1105     # unsafe meta access, ok?
1106     return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
1107     $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
1108 }
1109
1110 #-> sub CPAN::new ;
1111 sub new {
1112     bless {}, shift;
1113 }
1114
1115 #-> sub CPAN::cleanup ;
1116 sub cleanup {
1117   # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
1118   local $SIG{__DIE__} = '';
1119   my($message) = @_;
1120   my $i = 0;
1121   my $ineval = 0;
1122   my($subroutine);
1123   while ((undef,undef,undef,$subroutine) = caller(++$i)) {
1124       $ineval = 1, last if
1125           $subroutine eq '(eval)';
1126   }
1127   return if $ineval && !$CPAN::End;
1128   return unless defined $META->{LOCK};
1129   return unless -f $META->{LOCK};
1130   $META->savehist;
1131   unlink $META->{LOCK};
1132   # require Carp;
1133   # Carp::cluck("DEBUGGING");
1134   if ( $CPAN::CONFIG_DIRTY ) {
1135       $CPAN::Frontend->mywarn("Warning: Configuration not saved.\n");
1136   }
1137   $CPAN::Frontend->myprint("Lockfile removed.\n");
1138 }
1139
1140 #-> sub CPAN::savehist
1141 sub savehist {
1142     my($self) = @_;
1143     my($histfile,$histsize);
1144     unless ($histfile = $CPAN::Config->{'histfile'}){
1145         $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
1146         return;
1147     }
1148     $histsize = $CPAN::Config->{'histsize'} || 100;
1149     if ($CPAN::term){
1150         unless ($CPAN::term->can("GetHistory")) {
1151             $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
1152             return;
1153         }
1154     } else {
1155         return;
1156     }
1157     my @h = $CPAN::term->GetHistory;
1158     splice @h, 0, @h-$histsize if @h>$histsize;
1159     my($fh) = FileHandle->new;
1160     open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
1161     local $\ = local $, = "\n";
1162     print $fh @h;
1163     close $fh;
1164 }
1165
1166 #-> sub CPAN::is_tested
1167 sub is_tested {
1168     my($self,$what) = @_;
1169     $self->{is_tested}{$what} = 1;
1170 }
1171
1172 #-> sub CPAN::is_installed
1173 # unsets the is_tested flag: as soon as the thing is installed, it is
1174 # not needed in set_perl5lib anymore
1175 sub is_installed {
1176     my($self,$what) = @_;
1177     delete $self->{is_tested}{$what};
1178 }
1179
1180 #-> sub CPAN::set_perl5lib
1181 sub set_perl5lib {
1182     my($self,$for) = @_;
1183     unless ($for) {
1184         (undef,undef,undef,$for) = caller(1);
1185         $for =~ s/.*://;
1186     }
1187     $self->{is_tested} ||= {};
1188     return unless %{$self->{is_tested}};
1189     my $env = $ENV{PERL5LIB};
1190     $env = $ENV{PERLLIB} unless defined $env;
1191     my @env;
1192     push @env, $env if defined $env and length $env;
1193     #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
1194     #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
1195     my @dirs = map {("$_/blib/arch", "$_/blib/lib")} sort keys %{$self->{is_tested}};
1196     if (@dirs < 15) {
1197         $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB for $for\n");
1198     } else {
1199         my @d = map {s/^\Q$CPAN::Config->{'build_dir'}/%BUILDDIR%/; $_ }
1200             sort keys %{$self->{is_tested}};
1201         $CPAN::Frontend->myprint("Prepending blib/arch and blib/lib subdirs of ".
1202                                  "@d to PERL5LIB; ".
1203                                  "%BUILDDIR%=$CPAN::Config->{'build_dir'} ".
1204                                  "for $for\n"
1205                                 );
1206     }
1207
1208     $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1209 }
1210
1211 package CPAN::CacheMgr;
1212 use strict;
1213
1214 #-> sub CPAN::CacheMgr::as_string ;
1215 sub as_string {
1216     eval { require Data::Dumper };
1217     if ($@) {
1218         return shift->SUPER::as_string;
1219     } else {
1220         return Data::Dumper::Dumper(shift);
1221     }
1222 }
1223
1224 #-> sub CPAN::CacheMgr::cachesize ;
1225 sub cachesize {
1226     shift->{DU};
1227 }
1228
1229 #-> sub CPAN::CacheMgr::tidyup ;
1230 sub tidyup {
1231   my($self) = @_;
1232   return unless -d $self->{ID};
1233   while ($self->{DU} > $self->{'MAX'} ) {
1234     my($toremove) = shift @{$self->{FIFO}};
1235     $CPAN::Frontend->myprint(sprintf(
1236                                      "Deleting from cache".
1237                                      ": $toremove (%.1f>%.1f MB)\n",
1238                                      $self->{DU}, $self->{'MAX'})
1239                             );
1240     return if $CPAN::Signal;
1241     $self->force_clean_cache($toremove);
1242     return if $CPAN::Signal;
1243   }
1244 }
1245
1246 #-> sub CPAN::CacheMgr::dir ;
1247 sub dir {
1248     shift->{ID};
1249 }
1250
1251 #-> sub CPAN::CacheMgr::entries ;
1252 sub entries {
1253     my($self,$dir) = @_;
1254     return unless defined $dir;
1255     $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
1256     $dir ||= $self->{ID};
1257     my($cwd) = CPAN::anycwd();
1258     chdir $dir or Carp::croak("Can't chdir to $dir: $!");
1259     my $dh = DirHandle->new(File::Spec->curdir)
1260         or Carp::croak("Couldn't opendir $dir: $!");
1261     my(@entries);
1262     for ($dh->read) {
1263         next if $_ eq "." || $_ eq "..";
1264         if (-f $_) {
1265             push @entries, File::Spec->catfile($dir,$_);
1266         } elsif (-d _) {
1267             push @entries, File::Spec->catdir($dir,$_);
1268         } else {
1269             $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
1270         }
1271     }
1272     chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
1273     sort { -M $b <=> -M $a} @entries;
1274 }
1275
1276 #-> sub CPAN::CacheMgr::disk_usage ;
1277 sub disk_usage {
1278     my($self,$dir) = @_;
1279     return if exists $self->{SIZE}{$dir};
1280     return if $CPAN::Signal;
1281     my($Du) = 0;
1282     if (-e $dir) {
1283         unless (-x $dir) {
1284             unless (chmod 0755, $dir) {
1285                 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
1286                                         "permission to change the permission; cannot ".
1287                                         "estimate disk usage of '$dir'\n");
1288                 $CPAN::Frontend->mysleep(5);
1289                 return;
1290             }
1291         }
1292     } else {
1293         $CPAN::Frontend->mywarn("Directory '$dir' has gone. Cannot continue.\n");
1294         return;
1295     }
1296     find(
1297          sub {
1298            $File::Find::prune++ if $CPAN::Signal;
1299            return if -l $_;
1300            if ($^O eq 'MacOS') {
1301              require Mac::Files;
1302              my $cat  = Mac::Files::FSpGetCatInfo($_);
1303              $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
1304            } else {
1305              if (-d _) {
1306                unless (-x _) {
1307                  unless (chmod 0755, $_) {
1308                    $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
1309                                            "the permission to change the permission; ".
1310                                            "can only partially estimate disk usage ".
1311                                            "of '$_'\n");
1312                    $CPAN::Frontend->mysleep(5);
1313                    return;
1314                  }
1315                }
1316              } else {
1317                $Du += (-s _);
1318              }
1319            }
1320          },
1321          $dir
1322         );
1323     return if $CPAN::Signal;
1324     $self->{SIZE}{$dir} = $Du/1024/1024;
1325     push @{$self->{FIFO}}, $dir;
1326     $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
1327     $self->{DU} += $Du/1024/1024;
1328     $self->{DU};
1329 }
1330
1331 #-> sub CPAN::CacheMgr::force_clean_cache ;
1332 sub force_clean_cache {
1333     my($self,$dir) = @_;
1334     return unless -e $dir;
1335     $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
1336         if $CPAN::DEBUG;
1337     File::Path::rmtree($dir);
1338     unlink "$dir.yml"; # may fail
1339     $self->{DU} -= $self->{SIZE}{$dir};
1340     delete $self->{SIZE}{$dir};
1341 }
1342
1343 #-> sub CPAN::CacheMgr::new ;
1344 sub new {
1345     my $class = shift;
1346     my $time = time;
1347     my($debug,$t2);
1348     $debug = "";
1349     my $self = {
1350                 ID => $CPAN::Config->{'build_dir'},
1351                 MAX => $CPAN::Config->{'build_cache'},
1352                 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
1353                 DU => 0
1354                };
1355     File::Path::mkpath($self->{ID});
1356     my $dh = DirHandle->new($self->{ID});
1357     bless $self, $class;
1358     $self->scan_cache;
1359     $t2 = time;
1360     $debug .= "timing of CacheMgr->new: ".($t2 - $time);
1361     $time = $t2;
1362     CPAN->debug($debug) if $CPAN::DEBUG;
1363     $self;
1364 }
1365
1366 #-> sub CPAN::CacheMgr::scan_cache ;
1367 sub scan_cache {
1368     my $self = shift;
1369     return if $self->{SCAN} eq 'never';
1370     $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
1371         unless $self->{SCAN} eq 'atstart';
1372     $CPAN::Frontend->myprint(
1373                              sprintf("Scanning cache %s for sizes\n",
1374                                      $self->{ID}));
1375     my $e;
1376     for $e ($self->entries($self->{ID})) {
1377         next if $e eq ".." || $e eq ".";
1378         $self->disk_usage($e);
1379         return if $CPAN::Signal;
1380     }
1381     $self->tidyup;
1382 }
1383
1384 package CPAN::Shell;
1385 use strict;
1386
1387 #-> sub CPAN::Shell::h ;
1388 sub h {
1389     my($class,$about) = @_;
1390     if (defined $about) {
1391         $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1392     } else {
1393         my $filler = " " x (80 - 28 - length($CPAN::VERSION));
1394         $CPAN::Frontend->myprint(qq{
1395 Display Information $filler (ver $CPAN::VERSION)
1396  command  argument          description
1397  a,b,d,m  WORD or /REGEXP/  about authors, bundles, distributions, modules
1398  i        WORD or /REGEXP/  about any of the above
1399  ls       AUTHOR or GLOB    about files in the author's directory
1400     (with WORD being a module, bundle or author name or a distribution
1401     name of the form AUTHOR/DISTRIBUTION)
1402
1403 Download, Test, Make, Install...
1404  get      download                     clean    make clean
1405  make     make (implies get)           look     open subshell in dist directory
1406  test     make test (implies make)     readme   display these README files
1407  install  make install (implies test)  perldoc  display POD documentation
1408
1409 Upgrade
1410  r        WORDs or /REGEXP/ or NONE    report updates for some/matching/all modules
1411  upgrade  WORDs or /REGEXP/ or NONE    upgrade some/matching/all modules
1412
1413 Pragmas
1414  force COMMAND    unconditionally do command
1415  notest COMMAND   skip testing
1416
1417 Other
1418  h,?           display this menu       ! perl-code   eval a perl command
1419  o conf [opt]  set and query options   q             quit the cpan shell
1420  reload cpan   load CPAN.pm again      reload index  load newer indices
1421  autobundle    Snapshot                recent        latest CPAN uploads});
1422 }
1423 }
1424
1425 *help = \&h;
1426
1427 #-> sub CPAN::Shell::a ;
1428 sub a {
1429   my($self,@arg) = @_;
1430   # authors are always UPPERCASE
1431   for (@arg) {
1432     $_ = uc $_ unless /=/;
1433   }
1434   $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1435 }
1436
1437 #-> sub CPAN::Shell::globls ;
1438 sub globls {
1439     my($self,$s,$pragmas) = @_;
1440     # ls is really very different, but we had it once as an ordinary
1441     # command in the Shell (upto rev. 321) and we could not handle
1442     # force well then
1443     my(@accept,@preexpand);
1444     if ($s =~ /[\*\?\/]/) {
1445         if ($CPAN::META->has_inst("Text::Glob")) {
1446             if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
1447                 my $rau = Text::Glob::glob_to_regex(uc $au);
1448                 CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
1449                       if $CPAN::DEBUG;
1450                 push @preexpand, map { $_->id . "/" . $pathglob }
1451                     CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
1452             } else {
1453                 my $rau = Text::Glob::glob_to_regex(uc $s);
1454                 push @preexpand, map { $_->id }
1455                     CPAN::Shell->expand_by_method('CPAN::Author',
1456                                                   ['id'],
1457                                                   "/$rau/");
1458             }
1459         } else {
1460             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
1461         }
1462     } else {
1463         push @preexpand, uc $s;
1464     }
1465     for (@preexpand) {
1466         unless (/^[A-Z0-9\-]+(\/|$)/i) {
1467             $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
1468             next;
1469         }
1470         push @accept, $_;
1471     }
1472     my $silent = @accept>1;
1473     my $last_alpha = "";
1474     my @results;
1475     for my $a (@accept){
1476         my($author,$pathglob);
1477         if ($a =~ m|(.*?)/(.*)|) {
1478             my $a2 = $1;
1479             $pathglob = $2;
1480             $author = CPAN::Shell->expand_by_method('CPAN::Author',
1481                                                     ['id'],
1482                                                     $a2) or die "No author found for $a2";
1483         } else {
1484             $author = CPAN::Shell->expand_by_method('CPAN::Author',
1485                                                     ['id'],
1486                                                     $a) or die "No author found for $a";
1487         }
1488         if ($silent) {
1489             my $alpha = substr $author->id, 0, 1;
1490             my $ad;
1491             if ($alpha eq $last_alpha) {
1492                 $ad = "";
1493             } else {
1494                 $ad = "[$alpha]";
1495                 $last_alpha = $alpha;
1496             }
1497             $CPAN::Frontend->myprint($ad);
1498         }
1499         for my $pragma (@$pragmas) {
1500             if ($author->can($pragma)) {
1501                 $author->$pragma();
1502             }
1503         }
1504         push @results, $author->ls($pathglob,$silent); # silent if
1505                                                        # more than one
1506                                                        # author
1507         for my $pragma (@$pragmas) {
1508             my $unpragma = "un$pragma";
1509             if ($author->can($unpragma)) {
1510                 $author->$unpragma();
1511             }
1512         }
1513     }
1514     @results;
1515 }
1516
1517 #-> sub CPAN::Shell::local_bundles ;
1518 sub local_bundles {
1519     my($self,@which) = @_;
1520     my($incdir,$bdir,$dh);
1521     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1522         my @bbase = "Bundle";
1523         while (my $bbase = shift @bbase) {
1524             $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
1525             CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1526             if ($dh = DirHandle->new($bdir)) { # may fail
1527                 my($entry);
1528                 for $entry ($dh->read) {
1529                     next if $entry =~ /^\./;
1530                     next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/;
1531                     if (-d File::Spec->catdir($bdir,$entry)){
1532                         push @bbase, "$bbase\::$entry";
1533                     } else {
1534                         next unless $entry =~ s/\.pm(?!\n)\Z//;
1535                         $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1536                     }
1537                 }
1538             }
1539         }
1540     }
1541 }
1542
1543 #-> sub CPAN::Shell::b ;
1544 sub b {
1545     my($self,@which) = @_;
1546     CPAN->debug("which[@which]") if $CPAN::DEBUG;
1547     $self->local_bundles;
1548     $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1549 }
1550
1551 #-> sub CPAN::Shell::d ;
1552 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1553
1554 #-> sub CPAN::Shell::m ;
1555 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1556     my $self = shift;
1557     $CPAN::Frontend->myprint($self->format_result('Module',@_));
1558 }
1559
1560 #-> sub CPAN::Shell::i ;
1561 sub i {
1562     my($self) = shift;
1563     my(@args) = @_;
1564     @args = '/./' unless @args;
1565     my(@result);
1566     for my $type (qw/Bundle Distribution Module/) {
1567         push @result, $self->expand($type,@args);
1568     }
1569     # Authors are always uppercase.
1570     push @result, $self->expand("Author", map { uc $_ } @args);
1571
1572     my $result = @result == 1 ?
1573         $result[0]->as_string :
1574             @result == 0 ?
1575                 "No objects found of any type for argument @args\n" :
1576                     join("",
1577                          (map {$_->as_glimpse} @result),
1578                          scalar @result, " items found\n",
1579                         );
1580     $CPAN::Frontend->myprint($result);
1581 }
1582
1583 #-> sub CPAN::Shell::o ;
1584
1585 # CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o
1586 # conf' calls through to CPAN::HandleConfig::edit. 'o conf' should
1587 # probably have been called 'set' and 'o debug' maybe 'set debug' or
1588 # 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm
1589 sub o {
1590     my($self,$o_type,@o_what) = @_;
1591     $o_type ||= "";
1592     CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1593     if ($o_type eq 'conf') {
1594         if (!@o_what) { # print all things, "o conf"
1595             my($k,$v);
1596             $CPAN::Frontend->myprint("\$CPAN::Config options from ");
1597             my @from;
1598             if (exists $INC{'CPAN/Config.pm'}) {
1599                 push @from, $INC{'CPAN/Config.pm'};
1600             }
1601             if (exists $INC{'CPAN/MyConfig.pm'}) {
1602                 push @from, $INC{'CPAN/MyConfig.pm'};
1603             }
1604             $CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from);
1605             $CPAN::Frontend->myprint(":\n");
1606             for $k (sort keys %CPAN::HandleConfig::can) {
1607                 $v = $CPAN::HandleConfig::can{$k};
1608                 $CPAN::Frontend->myprint(sprintf "    %-18s [%s]\n", $k, $v);
1609             }
1610             $CPAN::Frontend->myprint("\n");
1611             for $k (sort keys %$CPAN::Config) {
1612                 CPAN::HandleConfig->prettyprint($k);
1613             }
1614             $CPAN::Frontend->myprint("\n");
1615         } else {
1616             if (CPAN::HandleConfig->edit(@o_what)) {
1617                 unless ($o_what[0] eq "init") {
1618                     $CPAN::Frontend->myprint("Please use 'o conf commit' to ".
1619                                              "make the config permanent!\n\n");
1620                 }
1621             } else {
1622                 $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
1623                                          qq{items\n\n});
1624             }
1625         }
1626     } elsif ($o_type eq 'debug') {
1627         my(%valid);
1628         @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1629         if (@o_what) {
1630             while (@o_what) {
1631                 my($what) = shift @o_what;
1632                 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
1633                     $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
1634                     next;
1635                 }
1636                 if ( exists $CPAN::DEBUG{$what} ) {
1637                     $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1638                 } elsif ($what =~ /^\d/) {
1639                     $CPAN::DEBUG = $what;
1640                 } elsif (lc $what eq 'all') {
1641                     my($max) = 0;
1642                     for (values %CPAN::DEBUG) {
1643                         $max += $_;
1644                     }
1645                     $CPAN::DEBUG = $max;
1646                 } else {
1647                     my($known) = 0;
1648                     for (keys %CPAN::DEBUG) {
1649                         next unless lc($_) eq lc($what);
1650                         $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1651                         $known = 1;
1652                     }
1653                     $CPAN::Frontend->myprint("unknown argument [$what]\n")
1654                         unless $known;
1655                 }
1656             }
1657         } else {
1658           my $raw = "Valid options for debug are ".
1659               join(", ",sort(keys %CPAN::DEBUG), 'all').
1660                   qq{ or a number. Completion works on the options. }.
1661                       qq{Case is ignored.};
1662           require Text::Wrap;
1663           $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1664           $CPAN::Frontend->myprint("\n\n");
1665         }
1666         if ($CPAN::DEBUG) {
1667             $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n");
1668             my($k,$v);
1669             for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1670                 $v = $CPAN::DEBUG{$k};
1671                 $CPAN::Frontend->myprint(sprintf "    %-14s(%s)\n", $k, $v)
1672                     if $v & $CPAN::DEBUG;
1673             }
1674         } else {
1675             $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1676         }
1677     } else {
1678         $CPAN::Frontend->myprint(qq{
1679 Known options:
1680   conf    set or get configuration variables
1681   debug   set or get debugging options
1682 });
1683     }
1684 }
1685
1686 # CPAN::Shell::paintdots_onreload
1687 sub paintdots_onreload {
1688     my($ref) = shift;
1689     sub {
1690         if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
1691             my($subr) = $1;
1692             ++$$ref;
1693             local($|) = 1;
1694             # $CPAN::Frontend->myprint(".($subr)");
1695             $CPAN::Frontend->myprint(".");
1696             if ($subr =~ /\bshell\b/i) {
1697                 # warn "debug[$_[0]]";
1698
1699                 # It would be nice if we could detect that a
1700                 # subroutine has actually changed, but for now we
1701                 # practically always set the GOTOSHELL global
1702
1703                 $CPAN::GOTOSHELL=1;
1704             }
1705             return;
1706         }
1707         warn @_;
1708     };
1709 }
1710
1711 #-> sub CPAN::Shell::hosts ;
1712 sub hosts {
1713     my($self) = @_;
1714     my $fullstats = CPAN::FTP->_ftp_statistics();
1715     my $history = $fullstats->{history} || [];
1716     my %S; # statistics
1717     while (my $last = pop @$history) {
1718         my $attempts = $last->{attempts} or next;
1719         my $start;
1720         if (@$attempts) {
1721             $start = $attempts->[-1]{start};
1722             if ($#$attempts > 0) {
1723                 for my $i (0..$#$attempts-1) {
1724                     my $url = $attempts->[$i]{url} or next;
1725                     $S{no}{$url}++;
1726                 }
1727             }
1728         } else {
1729             $start = $last->{start};
1730         }
1731         next unless $last->{thesiteurl}; # C-C? bad filenames?
1732         $S{start} = $start;
1733         $S{end} ||= $last->{end};
1734         my $dltime = $last->{end} - $start;
1735         my $dlsize = $last->{filesize} || 0;
1736         my $url = $last->{thesiteurl}->text;
1737         my $s = $S{ok}{$url} ||= {};
1738         $s->{n}++;
1739         $s->{dlsize} ||= 0;
1740         $s->{dlsize} += $dlsize/1024;
1741         $s->{dltime} ||= 0;
1742         $s->{dltime} += $dltime;
1743     }
1744     my $res;
1745     for my $url (keys %{$S{ok}}) {
1746         next if $S{ok}{$url}{dltime} == 0; # div by zero
1747         push @{$res->{ok}}, [@{$S{ok}{$url}}{qw(n dlsize dltime)},
1748                              $S{ok}{$url}{dlsize}/$S{ok}{$url}{dltime},
1749                              $url,
1750                             ];
1751     }
1752     for my $url (keys %{$S{no}}) {
1753         push @{$res->{no}}, [$S{no}{$url},
1754                              $url,
1755                             ];
1756     }
1757     my $R = ""; # report
1758     $R .= sprintf "Log starts: %s\n", scalar(localtime $S{start}) || "unknown";
1759     $R .= sprintf "Log ends  : %s\n", scalar(localtime $S{end}) || "unknown";
1760     if ($res->{ok} && @{$res->{ok}}) {
1761         $R .= sprintf "\nSuccessful downloads:
1762    N       kB  secs      kB/s url\n";
1763         for (sort { $b->[3] <=> $a->[3] } @{$res->{ok}}) {
1764             $R .= sprintf "%4d %8d %5d %9.1f %s\n", @$_;
1765         }
1766     }
1767     if ($res->{no} && @{$res->{no}}) {
1768         $R .= sprintf "\nUnsuccessful downloads:\n";
1769         for (sort { $b->[0] <=> $a->[0] } @{$res->{no}}) {
1770             $R .= sprintf "%4d %s\n", @$_;
1771         }
1772     }
1773     $CPAN::Frontend->myprint($R);
1774 }
1775
1776 #-> sub CPAN::Shell::reload ;
1777 sub reload {
1778     my($self,$command,@arg) = @_;
1779     $command ||= "";
1780     $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1781     if ($command =~ /^cpan$/i) {
1782         my $redef = 0;
1783         chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
1784         my $failed;
1785         my @relo = (
1786                     "CPAN.pm",
1787                     "CPAN/HandleConfig.pm",
1788                     "CPAN/FirstTime.pm",
1789                     "CPAN/Tarzip.pm",
1790                     "CPAN/Debug.pm",
1791                     "CPAN/Version.pm",
1792                     "CPAN/Queue.pm",
1793                     "CPAN/Reporter.pm",
1794                    );
1795       MFILE: for my $f (@relo) {
1796             next unless exists $INC{$f};
1797             my $p = $f;
1798             $p =~ s/\.pm$//;
1799             $p =~ s|/|::|g;
1800             $CPAN::Frontend->myprint("($p");
1801             local($SIG{__WARN__}) = paintdots_onreload(\$redef);
1802             $self->reload_this($f) or $failed++;
1803             my $v = eval "$p\::->VERSION";
1804             $CPAN::Frontend->myprint("v$v)");
1805         }
1806         $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1807         if ($failed) {
1808             my $errors = $failed == 1 ? "error" : "errors";
1809             $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ".
1810                                     "this session.\n");
1811         }
1812     } elsif ($command =~ /^index$/i) {
1813       CPAN::Index->force_reload;
1814     } else {
1815       $CPAN::Frontend->myprint(qq{cpan     re-evals the CPAN modules
1816 index    re-reads the index files\n});
1817     }
1818 }
1819
1820 # reload means only load again what we have loaded before
1821 #-> sub CPAN::Shell::reload_this ;
1822 sub reload_this {
1823     my($self,$f,$args) = @_;
1824     CPAN->debug("f[$f]") if $CPAN::DEBUG;
1825     return 1 unless $INC{$f}; # we never loaded this, so we do not
1826                               # reload but say OK
1827     my $pwd = CPAN::anycwd();
1828     CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG;
1829     my($file);
1830     for my $inc (@INC) {
1831         $file = File::Spec->catfile($inc,split /\//, $f);
1832         last if -f $file;
1833         $file = "";
1834     }
1835     CPAN->debug("file[$file]") if $CPAN::DEBUG;
1836     my @inc = @INC;
1837     unless ($file && -f $file) {
1838         # this thingie is not in the INC path, maybe CPAN/MyConfig.pm?
1839         $file = $INC{$f};
1840         unless (CPAN->has_inst("File::Basename")) {
1841             @inc = File::Basename::dirname($file);
1842         } else {
1843             # do we ever need this?
1844             @inc = substr($file,0,-length($f)-1); # bring in back to me!
1845         }
1846     }
1847     CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG;
1848     unless (-f $file) {
1849         $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
1850         return;
1851     }
1852     my $mtime = (stat $file)[9];
1853     $reload->{$f} ||= $^T;
1854     my $must_reload = $mtime > $reload->{$f};
1855     $args ||= {};
1856     $must_reload ||= $args->{force};
1857     if ($must_reload) {
1858         my $fh = FileHandle->new($file) or
1859             $CPAN::Frontend->mydie("Could not open $file: $!");
1860         local($/);
1861         local $^W = 1;
1862         my $content = <$fh>;
1863         CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
1864             if $CPAN::DEBUG;
1865         delete $INC{$f};
1866         local @INC = @inc;
1867         eval "require '$f'";
1868         if ($@){
1869             warn $@;
1870             return;
1871         }
1872         $reload->{$f} = time;
1873     } else {
1874         $CPAN::Frontend->myprint("__unchanged__");
1875     }
1876     return 1;
1877 }
1878
1879 #-> sub CPAN::Shell::mkmyconfig ;
1880 sub mkmyconfig {
1881     my($self, $cpanpm, %args) = @_;
1882     require CPAN::FirstTime;
1883     my $home = CPAN::HandleConfig::home;
1884     $cpanpm = $INC{'CPAN/MyConfig.pm'} ||
1885         File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm");
1886     File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm;
1887     CPAN::HandleConfig::require_myconfig_or_config;
1888     $CPAN::Config ||= {};
1889     $CPAN::Config = {
1890         %$CPAN::Config,
1891         build_dir           =>  undef,
1892         cpan_home           =>  undef,
1893         keep_source_where   =>  undef,
1894         histfile            =>  undef,
1895     };
1896     CPAN::FirstTime::init($cpanpm, %args);
1897 }
1898
1899 #-> sub CPAN::Shell::_binary_extensions ;
1900 sub _binary_extensions {
1901     my($self) = shift @_;
1902     my(@result,$module,%seen,%need,$headerdone);
1903     for $module ($self->expand('Module','/./')) {
1904         my $file  = $module->cpan_file;
1905         next if $file eq "N/A";
1906         next if $file =~ /^Contact Author/;
1907         my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
1908         next if $dist->isa_perl;
1909         next unless $module->xs_file;
1910         local($|) = 1;
1911         $CPAN::Frontend->myprint(".");
1912         push @result, $module;
1913     }
1914 #    print join " | ", @result;
1915     $CPAN::Frontend->myprint("\n");
1916     return @result;
1917 }
1918
1919 #-> sub CPAN::Shell::recompile ;
1920 sub recompile {
1921     my($self) = shift @_;
1922     my($module,@module,$cpan_file,%dist);
1923     @module = $self->_binary_extensions();
1924     for $module (@module){  # we force now and compile later, so we
1925                             # don't do it twice
1926         $cpan_file = $module->cpan_file;
1927         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1928         $pack->force;
1929         $dist{$cpan_file}++;
1930     }
1931     for $cpan_file (sort keys %dist) {
1932         $CPAN::Frontend->myprint("  CPAN: Recompiling $cpan_file\n\n");
1933         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1934         $pack->install;
1935         $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1936                            # stop a package from recompiling,
1937                            # e.g. IO-1.12 when we have perl5.003_10
1938     }
1939 }
1940
1941 #-> sub CPAN::Shell::scripts ;
1942 sub scripts {
1943     my($self, $arg) = @_;
1944     $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");
1945
1946     for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) {
1947         unless ($CPAN::META->has_inst($req)) {
1948             $CPAN::Frontend->mywarn("  $req not available\n");
1949         }
1950     }
1951     my $p = HTML::LinkExtor->new();
1952     my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html";
1953     unless (-f $indexfile) {
1954         $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n");
1955     }
1956     $p->parse_file($indexfile);
1957     my @hrefs;
1958     my $qrarg;
1959     if ($arg =~ s|^/(.+)/$|$1|) {
1960         $qrarg = eval 'qr/$arg/'; # hide construct from 5.004
1961     }
1962     for my $l ($p->links) {
1963         my $tag = shift @$l;
1964         next unless $tag eq "a";
1965         my %att = @$l;
1966         my $href = $att{href};
1967         next unless $href =~ s|^\.\./authors/id/./../||;
1968         if ($arg) {
1969             if ($qrarg) {
1970                 if ($href =~ $qrarg) {
1971                     push @hrefs, $href;
1972                 }
1973             } else {
1974                 if ($href =~ /\Q$arg\E/) {
1975                     push @hrefs, $href;
1976                 }
1977             }
1978         } else {
1979             push @hrefs, $href;
1980         }
1981     }
1982     # now filter for the latest version if there is more than one of a name
1983     my %stems;
1984     for (sort @hrefs) {
1985         my $href = $_;
1986         s/-v?\d.*//;
1987         my $stem = $_;
1988         $stems{$stem} ||= [];
1989         push @{$stems{$stem}}, $href;
1990     }
1991     for (sort keys %stems) {
1992         my $highest;
1993         if (@{$stems{$_}} > 1) {
1994             $highest = List::Util::reduce {
1995                 Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b
1996               } @{$stems{$_}};
1997         } else {
1998             $highest = $stems{$_}[0];
1999         }
2000         $CPAN::Frontend->myprint("$highest\n");
2001     }
2002 }
2003
2004 #-> sub CPAN::Shell::report ;
2005 sub report {
2006     my($self,@args) = @_;
2007     unless ($CPAN::META->has_inst("CPAN::Reporter")) {
2008         $CPAN::Frontend->mydie("CPAN::Reporter not installed; cannot continue");
2009     }
2010     local $CPAN::Config->{test_report} = 1;
2011     $self->force("test",@args); # force is there so that the test be
2012                                 # re-run (as documented)
2013 }
2014
2015 #-> sub CPAN::Shell::install_tested
2016 sub install_tested {
2017     my($self,@some) = @_;
2018     $CPAN::Frontend->mywarn("install_tested() requires no arguments.\n"),
2019         return if @some;
2020     CPAN::Index->reload;
2021
2022     for my $d (%{$CPAN::META->{readwrite}{'CPAN::Distribution'}}) {
2023         my $do = CPAN::Shell->expandany($d);
2024         next unless $do->{build_dir};
2025         push @some, $do;
2026     }
2027
2028     $CPAN::Frontend->mywarn("No tested distributions found.\n"),
2029         return unless @some;
2030
2031     @some = grep { $_->{make_test} && ! $_->{make_test}->failed } @some;
2032     $CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"),
2033         return unless @some;
2034
2035     @some = grep { not $_->uptodate } @some;
2036     $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"),
2037         return unless @some;
2038
2039     CPAN->debug("some[@some]");
2040     for my $d (@some) {
2041         my $id = $d->can("pretty_id") ? $d->pretty_id : $d->id;
2042         $CPAN::Frontend->myprint("install_tested: Running for $id\n");
2043         $CPAN::Frontend->sleep(1);
2044         $self->install($d);
2045     }
2046 }
2047
2048 #-> sub CPAN::Shell::upgrade ;
2049 sub upgrade {
2050     my($self,@args) = @_;
2051     $self->install($self->r(@args));
2052 }
2053
2054 #-> sub CPAN::Shell::_u_r_common ;
2055 sub _u_r_common {
2056     my($self) = shift @_;
2057     my($what) = shift @_;
2058     CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
2059     Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
2060           $what && $what =~ /^[aru]$/;
2061     my(@args) = @_;
2062     @args = '/./' unless @args;
2063     my(@result,$module,%seen,%need,$headerdone,
2064        $version_undefs,$version_zeroes);
2065     $version_undefs = $version_zeroes = 0;
2066     my $sprintf = "%s%-25s%s %9s %9s  %s\n";
2067     my @expand = $self->expand('Module',@args);
2068     my $expand = scalar @expand;
2069     if (0) { # Looks like noise to me, was very useful for debugging
2070              # for metadata cache
2071         $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
2072     }
2073   MODULE: for $module (@expand) {
2074         my $file  = $module->cpan_file;
2075         next MODULE unless defined $file; # ??
2076         $file =~ s|^./../||;
2077         my($latest) = $module->cpan_version;
2078         my($inst_file) = $module->inst_file;
2079         my($have);
2080         return if $CPAN::Signal;
2081         if ($inst_file){
2082             if ($what eq "a") {
2083                 $have = $module->inst_version;
2084             } elsif ($what eq "r") {
2085                 $have = $module->inst_version;
2086                 local($^W) = 0;
2087                 if ($have eq "undef"){
2088                     $version_undefs++;
2089                 } elsif ($have == 0){
2090                     $version_zeroes++;
2091                 }
2092                 next MODULE unless CPAN::Version->vgt($latest, $have);
2093 # to be pedantic we should probably say:
2094 #    && !($have eq "undef" && $latest ne "undef" && $latest gt "");
2095 # to catch the case where CPAN has a version 0 and we have a version undef
2096             } elsif ($what eq "u") {
2097                 next MODULE;
2098             }
2099         } else {
2100             if ($what eq "a") {
2101                 next MODULE;
2102             } elsif ($what eq "r") {
2103                 next MODULE;
2104             } elsif ($what eq "u") {
2105                 $have = "-";
2106             }
2107         }
2108         return if $CPAN::Signal; # this is sometimes lengthy
2109         $seen{$file} ||= 0;
2110         if ($what eq "a") {
2111             push @result, sprintf "%s %s\n", $module->id, $have;
2112         } elsif ($what eq "r") {
2113             push @result, $module->id;
2114             next MODULE if $seen{$file}++;
2115         } elsif ($what eq "u") {
2116             push @result, $module->id;
2117             next MODULE if $seen{$file}++;
2118             next MODULE if $file =~ /^Contact/;
2119         }
2120         unless ($headerdone++){
2121             $CPAN::Frontend->myprint("\n");
2122             $CPAN::Frontend->myprint(sprintf(
2123                                              $sprintf,
2124                                              "",
2125                                              "Package namespace",
2126                                              "",
2127                                              "installed",
2128                                              "latest",
2129                                              "in CPAN file"
2130                                             ));
2131         }
2132         my $color_on = "";
2133         my $color_off = "";
2134         if (
2135             $COLOR_REGISTERED
2136             &&
2137             $CPAN::META->has_inst("Term::ANSIColor")
2138             &&
2139             $module->description
2140            ) {
2141             $color_on = Term::ANSIColor::color("green");
2142             $color_off = Term::ANSIColor::color("reset");
2143         }
2144         $CPAN::Frontend->myprint(sprintf $sprintf,
2145                                  $color_on,
2146                                  $module->id,
2147                                  $color_off,
2148                                  $have,
2149                                  $latest,
2150                                  $file);
2151         $need{$module->id}++;
2152     }
2153     unless (%need) {
2154         if ($what eq "u") {
2155             $CPAN::Frontend->myprint("No modules found for @args\n");
2156         } elsif ($what eq "r") {
2157             $CPAN::Frontend->myprint("All modules are up to date for @args\n");
2158         }
2159     }
2160     if ($what eq "r") {
2161         if ($version_zeroes) {
2162             my $s_has = $version_zeroes > 1 ? "s have" : " has";
2163             $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
2164                 qq{a version number of 0\n});
2165         }
2166         if ($version_undefs) {
2167             my $s_has = $version_undefs > 1 ? "s have" : " has";
2168             $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
2169                 qq{parseable version number\n});
2170         }
2171     }
2172     @result;
2173 }
2174
2175 #-> sub CPAN::Shell::r ;
2176 sub r {
2177     shift->_u_r_common("r",@_);
2178 }
2179
2180 #-> sub CPAN::Shell::u ;
2181 sub u {
2182     shift->_u_r_common("u",@_);
2183 }
2184
2185 #-> sub CPAN::Shell::failed ;
2186 sub failed {
2187     my($self,$only_id,$silent) = @_;
2188     my @failed;
2189   DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
2190         my $failed = "";
2191       NAY: for my $nosayer (
2192                             "unwrapped",
2193                             "writemakefile",
2194                             "signature_verify",
2195                             "make",
2196                             "make_test",
2197                             "install",
2198                             "make_clean",
2199                            ) {
2200             next unless exists $d->{$nosayer};
2201             next unless (
2202                          $d->{$nosayer}->can("failed") ?
2203                          $d->{$nosayer}->failed :
2204                          $d->{$nosayer} =~ /^NO/
2205                         );
2206             next NAY if $only_id && $only_id != (
2207                                                  $d->{$nosayer}->can("commandid")
2208                                                  ?
2209                                                  $d->{$nosayer}->commandid
2210                                                  :
2211                                                  $CPAN::CurrentCommandId
2212                                                 );
2213             $failed = $nosayer;
2214             last;
2215         }
2216         next DIST unless $failed;
2217         my $id = $d->id;
2218         $id =~ s|^./../||;
2219         #$print .= sprintf(
2220         #                  "  %-45s: %s %s\n",
2221         push @failed,
2222             (
2223              $d->{$failed}->can("failed") ?
2224              [
2225               $d->{$failed}->commandid,
2226               $id,
2227               $failed,
2228               $d->{$failed}->text,
2229              ] :
2230              [
2231               1,
2232               $id,
2233               $failed,
2234               $d->{$failed},
2235              ]
2236             );
2237     }
2238     my $scope = $only_id ? "command" : "session";
2239     if (@failed) {
2240         my $print = join "",
2241             map { sprintf "  %-45s: %s %s\n", @$_[1,2,3] }
2242                 sort { $a->[0] <=> $b->[0] } @failed;
2243         $CPAN::Frontend->myprint("Failed during this $scope:\n$print");
2244     } elsif (!$only_id || !$silent) {
2245         $CPAN::Frontend->myprint("Nothing failed in this $scope\n");
2246     }
2247 }
2248
2249 # XXX intentionally undocumented because completely bogus, unportable,
2250 # useless, etc.
2251
2252 #-> sub CPAN::Shell::status ;
2253 sub status {
2254     my($self) = @_;
2255     require Devel::Size;
2256     my $ps = FileHandle->new;
2257     open $ps, "/proc/$$/status";
2258     my $vm = 0;
2259     while (<$ps>) {
2260         next unless /VmSize:\s+(\d+)/;
2261         $vm = $1;
2262         last;
2263     }
2264     $CPAN::Frontend->mywarn(sprintf(
2265                                     "%-27s %6d\n%-27s %6d\n",
2266                                     "vm",
2267                                     $vm,
2268                                     "CPAN::META",
2269                                     Devel::Size::total_size($CPAN::META)/1024,
2270                                    ));
2271     for my $k (sort keys %$CPAN::META) {
2272         next unless substr($k,0,4) eq "read";
2273         warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
2274         for my $k2 (sort keys %{$CPAN::META->{$k}}) {
2275             warn sprintf "  %-25s %6d (keys: %6d)\n",
2276                 $k2,
2277                     Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
2278                           scalar keys %{$CPAN::META->{$k}{$k2}};
2279         }
2280     }
2281 }
2282
2283 #-> sub CPAN::Shell::autobundle ;
2284 sub autobundle {
2285     my($self) = shift;
2286     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
2287     my(@bundle) = $self->_u_r_common("a",@_);
2288     my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
2289     File::Path::mkpath($todir);
2290     unless (-d $todir) {
2291         $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
2292         return;
2293     }
2294     my($y,$m,$d) =  (localtime)[5,4,3];
2295     $y+=1900;
2296     $m++;
2297     my($c) = 0;
2298     my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
2299     my($to) = File::Spec->catfile($todir,"$me.pm");
2300     while (-f $to) {
2301         $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
2302         $to = File::Spec->catfile($todir,"$me.pm");
2303     }
2304     my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
2305     $fh->print(
2306                "package Bundle::$me;\n\n",
2307                "\$VERSION = '0.01';\n\n",
2308                "1;\n\n",
2309                "__END__\n\n",
2310                "=head1 NAME\n\n",
2311                "Bundle::$me - Snapshot of installation on ",
2312                $Config::Config{'myhostname'},
2313                " on ",
2314                scalar(localtime),
2315                "\n\n=head1 SYNOPSIS\n\n",
2316                "perl -MCPAN -e 'install Bundle::$me'\n\n",
2317                "=head1 CONTENTS\n\n",
2318                join("\n", @bundle),
2319                "\n\n=head1 CONFIGURATION\n\n",
2320                Config->myconfig,
2321                "\n\n=head1 AUTHOR\n\n",
2322                "This Bundle has been generated automatically ",
2323                "by the autobundle routine in CPAN.pm.\n",
2324               );
2325     $fh->close;
2326     $CPAN::Frontend->myprint("\nWrote bundle file
2327     $to\n\n");
2328 }
2329
2330 #-> sub CPAN::Shell::expandany ;
2331 sub expandany {
2332     my($self,$s) = @_;
2333     CPAN->debug("s[$s]") if $CPAN::DEBUG;
2334     if ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory
2335         $s = CPAN::Distribution->normalize($s);
2336         return $CPAN::META->instance('CPAN::Distribution',$s);
2337         # Distributions spring into existence, not expand
2338     } elsif ($s =~ m|^Bundle::|) {
2339         $self->local_bundles; # scanning so late for bundles seems
2340                               # both attractive and crumpy: always
2341                               # current state but easy to forget
2342                               # somewhere
2343         return $self->expand('Bundle',$s);
2344     } else {
2345         return $self->expand('Module',$s)
2346             if $CPAN::META->exists('CPAN::Module',$s);
2347     }
2348     return;
2349 }
2350
2351 #-> sub CPAN::Shell::expand ;
2352 sub expand {
2353     my $self = shift;
2354     my($type,@args) = @_;
2355     CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
2356     my $class = "CPAN::$type";
2357     my $methods = ['id'];
2358     for my $meth (qw(name)) {
2359         next if $] < 5.00303; # no "can"
2360         next unless $class->can($meth);
2361         push @$methods, $meth;
2362     }
2363     $self->expand_by_method($class,$methods,@args);
2364 }
2365
2366 #-> sub CPAN::Shell::expand_by_method ;
2367 sub expand_by_method {
2368     my $self = shift;
2369     my($class,$methods,@args) = @_;
2370     my($arg,@m);
2371     for $arg (@args) {
2372         my($regex,$command);
2373         if ($arg =~ m|^/(.*)/$|) {
2374             $regex = $1;
2375         } elsif ($arg =~ m/=/) {
2376             $command = 1;
2377         }
2378         my $obj;
2379         CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
2380                     $class,
2381                     defined $regex ? $regex : "UNDEFINED",
2382                     defined $command ? $command : "UNDEFINED",
2383                    ) if $CPAN::DEBUG;
2384         if (defined $regex) {
2385             for $obj (
2386                       $CPAN::META->all_objects($class)
2387                      ) {
2388                 unless ($obj->id){
2389                     # BUG, we got an empty object somewhere
2390                     require Data::Dumper;
2391                     CPAN->debug(sprintf(
2392                                         "Bug in CPAN: Empty id on obj[%s][%s]",
2393                                         $obj,
2394                                         Data::Dumper::Dumper($obj)
2395                                        )) if $CPAN::DEBUG;
2396                     next;
2397                 }
2398                 for my $method (@$methods) {
2399                     my $match = eval {$obj->$method() =~ /$regex/i};
2400                     if ($@) {
2401                         my($err) = $@ =~ /^(.+) at .+? line \d+\.$/;
2402                         $err ||= $@; # if we were too restrictive above
2403                         $CPAN::Frontend->mydie("$err\n");
2404                     } elsif ($match) {
2405                         push @m, $obj;
2406                         last;
2407                     }
2408                 }
2409             }
2410         } elsif ($command) {
2411             die "equal sign in command disabled (immature interface), ".
2412                 "you can set
2413  ! \$CPAN::Shell::ADVANCED_QUERY=1
2414 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
2415 that may go away anytime.\n"
2416                     unless $ADVANCED_QUERY;
2417             my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
2418             my($matchcrit) = $criterion =~ m/^~(.+)/;
2419             for my $self (
2420                           sort
2421                           {$a->id cmp $b->id}
2422                           $CPAN::META->all_objects($class)
2423                          ) {
2424                 my $lhs = $self->$method() or next; # () for 5.00503
2425                 if ($matchcrit) {
2426                     push @m, $self if $lhs =~ m/$matchcrit/;
2427                 } else {
2428                     push @m, $self if $lhs eq $criterion;
2429                 }
2430             }
2431         } else {
2432             my($xarg) = $arg;
2433             if ( $class eq 'CPAN::Bundle' ) {
2434                 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
2435             } elsif ($class eq "CPAN::Distribution") {
2436                 $xarg = CPAN::Distribution->normalize($arg);
2437             } else {
2438                 $xarg =~ s/:+/::/g;
2439             }
2440             if ($CPAN::META->exists($class,$xarg)) {
2441                 $obj = $CPAN::META->instance($class,$xarg);
2442             } elsif ($CPAN::META->exists($class,$arg)) {
2443                 $obj = $CPAN::META->instance($class,$arg);
2444             } else {
2445                 next;
2446             }
2447             push @m, $obj;
2448         }
2449     }
2450     @m = sort {$a->id cmp $b->id} @m;
2451     if ( $CPAN::DEBUG ) {
2452         my $wantarray = wantarray;
2453         my $join_m = join ",", map {$_->id} @m;
2454         $self->debug("wantarray[$wantarray]join_m[$join_m]");
2455     }
2456     return wantarray ? @m : $m[0];
2457 }
2458
2459 #-> sub CPAN::Shell::format_result ;
2460 sub format_result {
2461     my($self) = shift;
2462     my($type,@args) = @_;
2463     @args = '/./' unless @args;
2464     my(@result) = $self->expand($type,@args);
2465     my $result = @result == 1 ?
2466         $result[0]->as_string :
2467             @result == 0 ?
2468                 "No objects of type $type found for argument @args\n" :
2469                     join("",
2470                          (map {$_->as_glimpse} @result),
2471                          scalar @result, " items found\n",
2472                         );
2473     $result;
2474 }
2475
2476 #-> sub CPAN::Shell::report_fh ;
2477 {
2478     my $installation_report_fh;
2479     my $previously_noticed = 0;
2480
2481     sub report_fh {
2482         return $installation_report_fh if $installation_report_fh;
2483         if ($CPAN::META->has_inst("File::Temp")) {
2484             $installation_report_fh
2485                 = File::Temp->new(
2486                                   template => 'cpan_install_XXXX',
2487                                   suffix   => '.txt',
2488                                   unlink   => 0,
2489                                  );
2490         }
2491         unless ( $installation_report_fh ) {
2492             warn("Couldn't open installation report file; " .
2493                  "no report file will be generated."
2494                 ) unless $previously_noticed++;
2495         }
2496     }
2497 }
2498
2499
2500 # The only reason for this method is currently to have a reliable
2501 # debugging utility that reveals which output is going through which
2502 # channel. No, I don't like the colors ;-)
2503
2504 # to turn colordebugging on, write
2505 # cpan> o conf colorize_output 1
2506
2507 #-> sub CPAN::Shell::print_ornamented ;
2508 {
2509     my $print_ornamented_have_warned = 0;
2510     sub colorize_output {
2511         my $colorize_output = $CPAN::Config->{colorize_output};
2512         if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
2513             unless ($print_ornamented_have_warned++) {
2514                 # no myprint/mywarn within myprint/mywarn!
2515                 warn "Colorize_output is set to true but Term::ANSIColor is not
2516 installed. To activate colorized output, please install Term::ANSIColor.\n\n";
2517             }
2518             $colorize_output = 0;
2519         }
2520         return $colorize_output;
2521     }
2522 }
2523
2524
2525 #-> sub CPAN::Shell::print_ornamented ;
2526 sub print_ornamented {
2527     my($self,$what,$ornament) = @_;
2528     return unless defined $what;
2529
2530     local $| = 1; # Flush immediately
2531     if ( $CPAN::Be_Silent ) {
2532         print {report_fh()} $what;
2533         return;
2534     }
2535     my $swhat = "$what"; # stringify if it is an object
2536     if ($CPAN::Config->{term_is_latin}){
2537         # courtesy jhi:
2538         $swhat
2539             =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
2540     }
2541     if ($self->colorize_output) {
2542         if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
2543             # if you want to have this configurable, please file a bugreport
2544             $ornament = "black on_cyan";
2545         }
2546         my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
2547         if ($@) {
2548             print "Term::ANSIColor rejects color[$ornament]: $@\n
2549 Please choose a different color (Hint: try 'o conf init color.*')\n";
2550         }
2551         print $color_on,
2552             $swhat,
2553                 Term::ANSIColor::color("reset");
2554     } else {
2555         print $swhat;
2556     }
2557 }
2558
2559 #-> sub CPAN::Shell::myprint ;
2560
2561 # where is myprint/mywarn/Frontend/etc. documented? We need guidelines
2562 # where to use what! I think, we send everything to STDOUT and use
2563 # print for normal/good news and warn for news that need more
2564 # attention. Yes, this is our working contract for now.
2565 sub myprint {
2566     my($self,$what) = @_;
2567
2568     $self->print_ornamented($what, $CPAN::Config->{colorize_print}||'bold blue on_white');
2569 }
2570
2571 #-> sub CPAN::Shell::myexit ;
2572 sub myexit {
2573     my($self,$what) = @_;
2574     $self->myprint($what);
2575     exit;
2576 }
2577
2578 #-> sub CPAN::Shell::mywarn ;
2579 sub mywarn {
2580     my($self,$what) = @_;
2581     $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
2582 }
2583
2584 # only to be used for shell commands
2585 #-> sub CPAN::Shell::mydie ;
2586 sub mydie {
2587     my($self,$what) = @_;
2588     $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
2589
2590     # If it is the shell, we want that the following die to be silent,
2591     # but if it is not the shell, we would need a 'die $what'. We need
2592     # to take care that only shell commands use mydie. Is this
2593     # possible?
2594
2595     die "\n";
2596 }
2597
2598 # sub CPAN::Shell::colorable_makemaker_prompt ;
2599 sub colorable_makemaker_prompt {
2600     my($foo,$bar) = @_;
2601     if (CPAN::Shell->colorize_output) {
2602         my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
2603         my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
2604         print $color_on;
2605     }
2606     my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
2607     if (CPAN::Shell->colorize_output) {
2608         print Term::ANSIColor::color('reset');
2609     }
2610     return $ans;
2611 }
2612
2613 # use this only for unrecoverable errors!
2614 #-> sub CPAN::Shell::unrecoverable_error ;
2615 sub unrecoverable_error {
2616     my($self,$what) = @_;
2617     my @lines = split /\n/, $what;
2618     my $longest = 0;
2619     for my $l (@lines) {
2620         $longest = length $l if length $l > $longest;
2621     }
2622     $longest = 62 if $longest > 62;
2623     for my $l (@lines) {
2624         if ($l =~ /^\s*$/){
2625             $l = "\n";
2626             next;
2627         }
2628         $l = "==> $l";
2629         if (length $l < 66) {
2630             $l = pack "A66 A*", $l, "<==";
2631         }
2632         $l .= "\n";
2633     }
2634     unshift @lines, "\n";
2635     $self->mydie(join "", @lines);
2636 }
2637
2638 #-> sub CPAN::Shell::mysleep ;
2639 sub mysleep {
2640     my($self, $sleep) = @_;
2641     sleep $sleep;
2642 }
2643
2644 #-> sub CPAN::Shell::setup_output ;
2645 sub setup_output {
2646     return if -t STDOUT;
2647     my $odef = select STDERR;
2648     $| = 1;
2649     select STDOUT;
2650     $| = 1;
2651     select $odef;
2652 }
2653
2654 #-> sub CPAN::Shell::rematein ;
2655 # RE-adme||MA-ke||TE-st||IN-stall
2656 sub rematein {
2657     my $self = shift;
2658     my($meth,@some) = @_;
2659     my @pragma;
2660     while($meth =~ /^(force|notest)$/) {
2661         push @pragma, $meth;
2662         $meth = shift @some or
2663             $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
2664                                    "cannot continue");
2665     }
2666     setup_output();
2667     CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
2668
2669     # Here is the place to set "test_count" on all involved parties to
2670     # 0. We then can pass this counter on to the involved
2671     # distributions and those can refuse to test if test_count > X. In
2672     # the first stab at it we could use a 1 for "X".
2673
2674     # But when do I reset the distributions to start with 0 again?
2675     # Jost suggested to have a random or cycling interaction ID that
2676     # we pass through. But the ID is something that is just left lying
2677     # around in addition to the counter, so I'd prefer to set the
2678     # counter to 0 now, and repeat at the end of the loop. But what
2679     # about dependencies? They appear later and are not reset, they
2680     # enter the queue but not its copy. How do they get a sensible
2681     # test_count?
2682
2683     # construct the queue
2684     my($s,@s,@qcopy);
2685   STHING: foreach $s (@some) {
2686         my $obj;
2687         if (ref $s) {
2688             CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
2689             $obj = $s;
2690         } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
2691         } elsif ($s =~ m|^/|) { # looks like a regexp
2692             if (substr($s,-1,1) eq ".") {
2693                 $obj = CPAN::Shell->expandany($s);
2694             } else {
2695                 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
2696                                         "not supported.\nRejecting argument '$s'\n");
2697                 $CPAN::Frontend->mysleep(2);
2698                 next;
2699             }
2700         } elsif ($meth eq "ls") {
2701             $self->globls($s,\@pragma);
2702             next STHING;
2703         } else {
2704             CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
2705             $obj = CPAN::Shell->expandany($s);
2706         }
2707         if (0) {
2708         } elsif (ref $obj) {
2709             $obj->color_cmd_tmps(0,1);
2710             CPAN::Queue->new(qmod => $obj->id, reqtype => "c");
2711             push @qcopy, $obj;
2712         } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
2713             $obj = $CPAN::META->instance('CPAN::Author',uc($s));
2714             if ($meth =~ /^(dump|ls)$/) {
2715                 $obj->$meth();
2716             } else {
2717                 $CPAN::Frontend->mywarn(
2718                                         join "",
2719                                         "Don't be silly, you can't $meth ",
2720                                         $obj->fullname,
2721                                         " ;-)\n"
2722                                        );
2723                 $CPAN::Frontend->mysleep(2);
2724             }
2725         } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
2726             CPAN::InfoObj->dump($s);
2727         } else {
2728             $CPAN::Frontend
2729                 ->mywarn(qq{Warning: Cannot $meth $s, }.
2730                           qq{don't know what it is.
2731 Try the command
2732
2733     i /$s/
2734
2735 to find objects with matching identifiers.
2736 });
2737             $CPAN::Frontend->mysleep(2);
2738         }
2739     }
2740
2741     # queuerunner (please be warned: when I started to change the
2742     # queue to hold objects instead of names, I made one or two
2743     # mistakes and never found which. I reverted back instead)
2744     while (my $q = CPAN::Queue->first) {
2745         my $obj;
2746         my $s = $q->as_string;
2747         my $reqtype = $q->reqtype || "";
2748         $obj = CPAN::Shell->expandany($s);
2749         $obj->{reqtype} ||= "";
2750         CPAN->debug("obj-reqtype[$obj->{reqtype}]".
2751                     "q-reqtype[$reqtype]") if $CPAN::DEBUG;
2752         if ($obj->{reqtype}) {
2753             if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
2754                 $obj->{reqtype} = $reqtype;
2755                 if (
2756                     exists $obj->{install}
2757                     &&
2758                     (
2759                      $obj->{install}->can("failed") ?
2760                      $obj->{install}->failed :
2761                      $obj->{install} =~ /^NO/
2762                     )
2763                    ) {
2764                     delete $obj->{install};
2765                     $CPAN::Frontend->mywarn
2766                         ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
2767                 }
2768             }
2769         } else {
2770             $obj->{reqtype} = $reqtype;
2771         }
2772
2773         for my $pragma (@pragma) {
2774             if ($pragma
2775                 &&
2776                 $obj->can($pragma)){
2777                 $obj->$pragma($meth);
2778             }
2779         }
2780         if ($obj->can('called_for')) {
2781             $obj->called_for($s);
2782         }
2783         CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
2784                     qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
2785
2786         push @qcopy, $obj;
2787         if ($obj->$meth()){
2788             CPAN::Queue->delete($s);
2789         } else {
2790             CPAN->debug("failed");
2791         }
2792
2793         $obj->undelay;
2794         for my $pragma (@pragma) {
2795             my $unpragma = "un$pragma";
2796             if ($obj->can($unpragma)) {
2797                 $obj->$unpragma();
2798             }
2799         }
2800         CPAN::Queue->delete_first($s);
2801     }
2802     for my $obj (@qcopy) {
2803         $obj->color_cmd_tmps(0,0);
2804     }
2805 }
2806
2807 #-> sub CPAN::Shell::recent ;
2808 sub recent {
2809   my($self) = @_;
2810
2811   CPAN::Distribution::_display_url( $self, $CPAN::Defaultrecent );
2812   return;
2813 }
2814
2815 {
2816     # set up the dispatching methods
2817     no strict "refs";
2818     for my $command (qw(
2819                         clean
2820                         cvs_import
2821                         dump
2822                         force
2823                         get
2824                         install
2825                         look
2826                         ls
2827                         make
2828                         notest
2829                         perldoc
2830                         readme
2831                         test
2832                        )) {
2833         *$command = sub { shift->rematein($command, @_); };
2834     }
2835 }
2836
2837 package CPAN::LWP::UserAgent;
2838 use strict;
2839
2840 sub config {
2841     return if $SETUPDONE;
2842     if ($CPAN::META->has_usable('LWP::UserAgent')) {
2843         require LWP::UserAgent;
2844         @ISA = qw(Exporter LWP::UserAgent);
2845         $SETUPDONE++;
2846     } else {
2847         $CPAN::Frontend->mywarn("  LWP::UserAgent not available\n");
2848     }
2849 }
2850
2851 sub get_basic_credentials {
2852     my($self, $realm, $uri, $proxy) = @_;
2853     if ($USER && $PASSWD) {
2854         return ($USER, $PASSWD);
2855     }
2856     if ( $proxy ) {
2857         ($USER,$PASSWD) = $self->get_proxy_credentials();
2858     } else {
2859         ($USER,$PASSWD) = $self->get_non_proxy_credentials();
2860     }
2861     return($USER,$PASSWD);
2862 }
2863
2864 sub get_proxy_credentials {
2865     my $self = shift;
2866     my ($user, $password);
2867     if ( defined $CPAN::Config->{proxy_user} &&
2868          defined $CPAN::Config->{proxy_pass}) {
2869         $user = $CPAN::Config->{proxy_user};
2870         $password = $CPAN::Config->{proxy_pass};
2871         return ($user, $password);
2872     }
2873     my $username_prompt = "\nProxy authentication needed!
2874  (Note: to permanently configure username and password run
2875    o conf proxy_user your_username
2876    o conf proxy_pass your_password
2877      )\nUsername:";
2878     ($user, $password) =
2879         _get_username_and_password_from_user($username_prompt);
2880     return ($user,$password);
2881 }
2882
2883 sub get_non_proxy_credentials {
2884     my $self = shift;
2885     my ($user,$password);
2886     if ( defined $CPAN::Config->{username} &&
2887          defined $CPAN::Config->{password}) {
2888         $user = $CPAN::Config->{username};
2889         $password = $CPAN::Config->{password};
2890         return ($user, $password);
2891     }
2892     my $username_prompt = "\nAuthentication needed!
2893      (Note: to permanently configure username and password run
2894        o conf username your_username
2895        o conf password your_password
2896      )\nUsername:";
2897
2898     ($user, $password) =
2899         _get_username_and_password_from_user($username_prompt);
2900     return ($user,$password);
2901 }
2902
2903 sub _get_username_and_password_from_user {
2904     my $username_message = shift;
2905     my ($username,$password);
2906
2907     ExtUtils::MakeMaker->import(qw(prompt));
2908     $username = prompt($username_message);
2909         if ($CPAN::META->has_inst("Term::ReadKey")) {
2910             Term::ReadKey::ReadMode("noecho");
2911         }
2912     else {
2913         $CPAN::Frontend->mywarn(
2914             "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"
2915         );
2916     }
2917     $password = prompt("Password:");
2918
2919         if ($CPAN::META->has_inst("Term::ReadKey")) {
2920             Term::ReadKey::ReadMode("restore");
2921         }
2922         $CPAN::Frontend->myprint("\n\n");
2923     return ($username,$password);
2924 }
2925
2926 # mirror(): Its purpose is to deal with proxy authentication. When we
2927 # call SUPER::mirror, we relly call the mirror method in
2928 # LWP::UserAgent. LWP::UserAgent will then call
2929 # $self->get_basic_credentials or some equivalent and this will be
2930 # $self->dispatched to our own get_basic_credentials method.
2931
2932 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
2933
2934 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
2935 # although we have gone through our get_basic_credentials, the proxy
2936 # server refuses to connect. This could be a case where the username or
2937 # password has changed in the meantime, so I'm trying once again without
2938 # $USER and $PASSWD to give the get_basic_credentials routine another
2939 # chance to set $USER and $PASSWD.
2940
2941 # mirror(): Its purpose is to deal with proxy authentication. When we
2942 # call SUPER::mirror, we relly call the mirror method in
2943 # LWP::UserAgent. LWP::UserAgent will then call
2944 # $self->get_basic_credentials or some equivalent and this will be
2945 # $self->dispatched to our own get_basic_credentials method.
2946
2947 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
2948
2949 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
2950 # although we have gone through our get_basic_credentials, the proxy
2951 # server refuses to connect. This could be a case where the username or
2952 # password has changed in the meantime, so I'm trying once again without
2953 # $USER and $PASSWD to give the get_basic_credentials routine another
2954 # chance to set $USER and $PASSWD.
2955
2956 sub mirror {
2957     my($self,$url,$aslocal) = @_;
2958     my $result = $self->SUPER::mirror($url,$aslocal);
2959     if ($result->code == 407) {
2960         undef $USER;
2961         undef $PASSWD;
2962         $result = $self->SUPER::mirror($url,$aslocal);
2963     }
2964     $result;
2965 }
2966
2967 package CPAN::FTP;
2968 use strict;
2969
2970 #-> sub CPAN::FTP::ftp_statistics
2971 # if they want to rewrite, they need to pass in a filehandle
2972 sub _ftp_statistics {
2973     my($self,$fh) = @_;
2974     my $locktype = $fh ? LOCK_EX : LOCK_SH;
2975     $fh ||= FileHandle->new;
2976     my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
2977     open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!");
2978     my $sleep = 1;
2979     while (!flock $fh, $locktype|LOCK_NB) {
2980         if ($sleep>3) {
2981             die;
2982         }
2983         $CPAN::Frontend->mysleep($sleep++);
2984     }
2985     my $stats = CPAN->_yaml_loadfile($file);
2986     if ($locktype == LOCK_SH) {
2987     } else {
2988         seek $fh, 0, 0;
2989         if (@$stats){ # no yaml no write
2990             truncate $fh, 0;
2991         }
2992     }
2993     return $stats->[0];
2994 }
2995
2996 sub _mytime () {
2997     if (CPAN->has_inst("Time::HiRes")) {
2998         return Time::HiRes::time();
2999     } else {
3000         return time;
3001     }
3002 }
3003
3004 sub _new_stats {
3005     my($self,$file) = @_;
3006     my $ret = {
3007                file => $file,
3008                attempts => [],
3009                start => _mytime,
3010               };
3011     $ret;
3012 }
3013
3014 sub _add_to_statistics {
3015     my($self,$stats) = @_;
3016     $stats->{thesiteurl} = $ThesiteURL;
3017     if (CPAN->has_inst("Time::HiRes")) {
3018         $stats->{end} = Time::HiRes::time();
3019     } else {
3020         $stats->{end} = time;
3021     }
3022     my $fh = FileHandle->new;
3023     my $fullstats = $self->_ftp_statistics($fh);
3024     push @{$fullstats->{history}}, $stats;
3025     my $time = time;
3026     shift @{$fullstats->{history}}
3027         while $time - $fullstats->{history}[0]{start} > 30*86400; # one month too much?
3028     CPAN->_yaml_dumpfile($fh,$fullstats);
3029 }
3030
3031 # if file is CHECKSUMS, suggest the place where we got the file to be
3032 # checked from, maybe only for young files?
3033 sub _recommend_url_for {
3034     my($self, $file) = @_;
3035     my $urllist = $self->_get_urllist;
3036     if ($file =~ s|/CHECKSUMS(.gz)?$||) {
3037         my $fullstats = $self->_ftp_statistics();
3038         my $history = $fullstats->{history} || [];
3039         while (my $last = pop @$history) {
3040             last if $last->{end} - time > 3600; # only young results are interesting
3041             next unless $file eq File::Basename::dirname($last->{file});
3042             return $last->{thesiteurl};
3043         }
3044     }
3045     if ($CPAN::Config->{randomize_urllist}
3046         &&
3047         rand(1) < $CPAN::Config->{randomize_urllist}
3048        ) {
3049         $urllist->[int rand scalar @$urllist];
3050     } else {
3051         return ();
3052     }
3053 }
3054
3055 sub _get_urllist {
3056     my($self) = @_;
3057     $CPAN::Config->{urllist} ||= [];
3058     unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
3059         $CPAN::Frontend->mywarn("Malformed urllist; ignoring.  Configuration file corrupt?\n");
3060         $CPAN::Config->{urllist} = [];
3061     }
3062     my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}};
3063     for my $u (@urllist) {
3064         CPAN->debug("u[$u]") if $CPAN::DEBUG;
3065         if (UNIVERSAL::can($u,"text")) {
3066             $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
3067         } else {
3068             $u .= "/" unless substr($u,-1) eq "/";
3069             $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
3070         }
3071     }
3072     \@urllist;
3073 }
3074
3075 #-> sub CPAN::FTP::ftp_get ;
3076 sub ftp_get {
3077     my($class,$host,$dir,$file,$target) = @_;
3078     $class->debug(
3079                   qq[Going to fetch file [$file] from dir [$dir]
3080         on host [$host] as local [$target]\n]
3081                  ) if $CPAN::DEBUG;
3082     my $ftp = Net::FTP->new($host);
3083     unless ($ftp) {
3084         $CPAN::Frontend->mywarn("  Could not connect to host '$host' with Net::FTP\n");
3085         return;
3086     }
3087     return 0 unless defined $ftp;
3088     $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
3089     $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
3090     unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
3091         my $msg = $ftp->message;
3092         $CPAN::Frontend->mywarn("  Couldn't login on $host: $msg");
3093         return;
3094     }
3095     unless ( $ftp->cwd($dir) ){
3096         my $msg = $ftp->message;
3097         $CPAN::Frontend->mywarn("  Couldn't cwd $dir: $msg");
3098         return;
3099     }
3100     $ftp->binary;
3101     $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
3102     unless ( $ftp->get($file,$target) ){
3103         my $msg = $ftp->message;
3104         $CPAN::Frontend->mywarn("  Couldn't fetch $file from $host: $msg");
3105         return;
3106     }
3107     $ftp->quit; # it's ok if this fails
3108     return 1;
3109 }
3110
3111 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
3112
3113  # > *** /install/perl/live/lib/CPAN.pm-        Wed Sep 24 13:08:48 1997
3114  # > --- /tmp/cp        Wed Sep 24 13:26:40 1997
3115  # > ***************
3116  # > *** 1562,1567 ****
3117  # > --- 1562,1580 ----
3118  # >       return 1 if substr($url,0,4) eq "file";
3119  # >       return 1 unless $url =~ m|://([^/]+)|;
3120  # >       my $host = $1;
3121  # > +     my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
3122  # > +     if ($proxy) {
3123  # > +         $proxy =~ m|://([^/:]+)|;
3124  # > +         $proxy = $1;
3125  # > +         my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
3126  # > +         if ($noproxy) {
3127  # > +             if ($host !~ /$noproxy$/) {
3128  # > +                 $host = $proxy;
3129  # > +             }
3130  # > +         } else {
3131  # > +             $host = $proxy;
3132  # > +         }
3133  # > +     }
3134  # >       require Net::Ping;
3135  # >       return 1 unless $Net::Ping::VERSION >= 2;
3136  # >       my $p;
3137
3138
3139 #-> sub CPAN::FTP::localize ;
3140 sub localize {
3141     my($self,$file,$aslocal,$force) = @_;
3142     $force ||= 0;
3143     Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
3144         unless defined $aslocal;
3145     $self->debug("file[$file] aslocal[$aslocal] force[$force]")
3146         if $CPAN::DEBUG;
3147
3148     if ($^O eq 'MacOS') {
3149         # Comment by AK on 2000-09-03: Uniq short filenames would be
3150         # available in CHECKSUMS file
3151         my($name, $path) = File::Basename::fileparse($aslocal, '');
3152         if (length($name) > 31) {
3153             $name =~ s/(
3154                         \.(
3155                            readme(\.(gz|Z))? |
3156                            (tar\.)?(gz|Z) |
3157                            tgz |
3158                            zip |
3159                            pm\.(gz|Z)
3160                           )
3161                        )$//x;
3162             my $suf = $1;
3163             my $size = 31 - length($suf);
3164             while (length($name) > $size) {
3165                 chop $name;
3166             }
3167             $name .= $suf;
3168             $aslocal = File::Spec->catfile($path, $name);
3169         }
3170     }
3171
3172     if (-f $aslocal && -r _ && !($force & 1)){
3173         my $size;
3174         if ($size = -s $aslocal) {
3175             $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
3176             return $aslocal;
3177         } else {
3178             # empty file from a previous unsuccessful attempt to download it
3179             unlink $aslocal or
3180                 $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
3181                                        "could not remove.");
3182         }
3183     }
3184     my($maybe_restore) = 0;
3185     if (-f $aslocal){
3186         rename $aslocal, "$aslocal.bak$$";
3187         $maybe_restore++;
3188     }
3189
3190     my($aslocal_dir) = File::Basename::dirname($aslocal);
3191     File::Path::mkpath($aslocal_dir);
3192     $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
3193         qq{directory "$aslocal_dir".
3194     I\'ll continue, but if you encounter problems, they may be due
3195     to insufficient permissions.\n}) unless -w $aslocal_dir;
3196
3197     # Inheritance is not easier to manage than a few if/else branches
3198     if ($CPAN::META->has_usable('LWP::UserAgent')) {
3199         unless ($Ua) {
3200             CPAN::LWP::UserAgent->config;
3201             eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
3202             if ($@) {
3203                 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
3204                     if $CPAN::DEBUG;
3205             } else {
3206                 my($var);
3207                 $Ua->proxy('ftp',  $var)
3208                     if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
3209                 $Ua->proxy('http', $var)
3210                     if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
3211
3212
3213 # >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
3214 #
3215 #  > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
3216 #  > use ones that require basic autorization.
3217 #
3218 #  > Example of when I use it manually in my own stuff:
3219 #
3220 #  > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
3221 #  > $req->proxy_authorization_basic("username","password");
3222 #  > $res = $ua->request($req);
3223 #
3224
3225                 $Ua->no_proxy($var)
3226                     if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
3227             }
3228         }
3229     }
3230     for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
3231         $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
3232     }
3233
3234     # Try the list of urls for each single object. We keep a record
3235     # where we did get a file from
3236     my(@reordered,$last);
3237     my $ccurllist = $self->_get_urllist;
3238     $last = $#$ccurllist;
3239     if ($force & 2) { # local cpans probably out of date, don't reorder
3240         @reordered = (0..$last);
3241     } else {
3242         @reordered =
3243             sort {
3244                 (substr($ccurllist->[$b],0,4) eq "file")
3245                     <=>
3246                 (substr($ccurllist->[$a],0,4) eq "file")
3247                     or
3248                 defined($ThesiteURL)
3249                     and
3250                 ($ccurllist->[$b] eq $ThesiteURL)
3251                     <=>
3252                 ($ccurllist->[$a] eq $ThesiteURL)
3253             } 0..$last;
3254     }
3255     my(@levels);
3256     $Themethod ||= "";
3257     $self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG;
3258     if ($Themethod) {
3259         @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
3260     } else {
3261         @levels = qw/easy hard hardest/;
3262     }
3263     @levels = qw/easy/ if $^O eq 'MacOS';
3264     my($levelno);
3265     local $ENV{FTP_PASSIVE} =
3266         exists $CPAN::Config->{ftp_passive} ?
3267         $CPAN::Config->{ftp_passive} : 1;
3268     my $ret;
3269     my $stats = $self->_new_stats($file);
3270   LEVEL: for $levelno (0..$#levels) {
3271         my $level = $levels[$levelno];
3272         my $method = "host$level";
3273         my @host_seq = $level eq "easy" ?
3274             @reordered : 0..$last;  # reordered has CDROM up front
3275         my @urllist = map { $ccurllist->[$_] } @host_seq;
3276         for my $u (@CPAN::Defaultsites) {
3277             push @urllist, $u unless grep { $_ eq $u } @urllist;
3278         }
3279         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
3280         my $aslocal_tempfile = $aslocal . ".tmp" . $$;
3281         if (my $recommend = $self->_recommend_url_for($file)) {
3282             @urllist = grep { $_ ne $recommend } @urllist;
3283             unshift @urllist, $recommend;
3284         }
3285         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
3286         $ret = $self->$method(\@urllist,$file,$aslocal_tempfile,$stats);
3287         if ($ret) {
3288             CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG;
3289             if ($ret eq $aslocal_tempfile) {
3290                 # if we got it exactly as we asked for, only then we
3291                 # want to rename
3292                 rename $aslocal_tempfile, $aslocal
3293                     or $CPAN::Frontend->mydie("Error while trying to rename ".
3294                                               "'$ret' to '$aslocal': $!");
3295                 $ret = $aslocal;
3296             }
3297             $Themethod = $level;
3298             my $now = time;
3299             # utime $now, $now, $aslocal; # too bad, if we do that, we
3300                                           # might alter a local mirror
3301             $self->debug("level[$level]") if $CPAN::DEBUG;
3302             last LEVEL;
3303         } else {
3304             unlink $aslocal_tempfile;
3305             last if $CPAN::Signal; # need to cleanup
3306         }
3307     }
3308     if ($ret) {
3309         $stats->{filesize} = -s $ret;
3310     }
3311     $self->_add_to_statistics($stats);
3312     if ($ret) {
3313         return $ret;
3314     }
3315     unless ($CPAN::Signal) {
3316         my(@mess);
3317         local $" = " ";
3318         if (@{$CPAN::Config->{urllist}}) {
3319             push @mess,
3320                 qq{Please check, if the URLs I found in your configuration file \(}.
3321                     join(", ", @{$CPAN::Config->{urllist}}).
3322                         qq{\) are valid.};
3323         } else {
3324             push @mess, qq{Your urllist is empty!};
3325         }
3326         push @mess, qq{The urllist can be edited.},
3327             qq{E.g. with 'o conf urllist push ftp://myurl/'};
3328         $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
3329         $CPAN::Frontend->mywarn("Could not fetch $file\n");
3330         $CPAN::Frontend->mysleep(2);
3331     }
3332     if ($maybe_restore) {
3333         rename "$aslocal.bak$$", $aslocal;
3334         $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
3335                                  $self->ls($aslocal));
3336         return $aslocal;
3337     }
3338     return;
3339 }
3340
3341 sub _set_attempt {
3342     my($self,$stats,$method,$url) = @_;
3343     push @{$stats->{attempts}}, {
3344                                  method => $method,
3345                                  start => _mytime,
3346                                  url => $url,
3347                                 };
3348 }
3349
3350 # package CPAN::FTP;
3351 sub hosteasy {
3352     my($self,$host_seq,$file,$aslocal,$stats) = @_;
3353     my($ro_url);
3354   HOSTEASY: for $ro_url (@$host_seq) {
3355         $self->_set_attempt($stats,"easy",$ro_url);
3356         my $url .= "$ro_url$file";
3357         $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
3358         if ($url =~ /^file:/) {
3359             my $l;
3360             if ($CPAN::META->has_inst('URI::URL')) {
3361                 my $u =  URI::URL->new($url);
3362                 $l = $u->path;
3363             } else { # works only on Unix, is poorly constructed, but
3364                 # hopefully better than nothing.
3365                 # RFC 1738 says fileurl BNF is
3366                 # fileurl = "file://" [ host | "localhost" ] "/" fpath
3367                 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
3368                 # the code
3369                 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
3370                 $l =~ s|^file:||;                   # assume they
3371                                                     # meant
3372                                                     # file://localhost
3373                 $l =~ s|^/||s
3374                     if ! -f $l && $l =~ m|^/\w:|;   # e.g. /P:
3375             }
3376             $self->debug("local file[$l]") if $CPAN::DEBUG;
3377             if ( -f $l && -r _) {
3378                 $ThesiteURL = $ro_url;
3379                 return $l;
3380             }
3381             if ($l =~ /(.+)\.gz$/) {
3382                 my $ungz = $1;
3383                 if ( -f $ungz && -r _) {
3384                     $ThesiteURL = $ro_url;
3385                     return $ungz;
3386                 }
3387             }
3388             # Maybe mirror has compressed it?
3389             if (-f "$l.gz") {
3390                 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
3391                 CPAN::Tarzip->new("$l.gz")->gunzip($aslocal);
3392                 if ( -f $aslocal) {
3393                     $ThesiteURL = $ro_url;
3394                     return $aslocal;
3395                 }
3396             }
3397         }
3398         $self->debug("it was not a file URL") if $CPAN::DEBUG;
3399         if ($CPAN::META->has_usable('LWP')) {
3400             $CPAN::Frontend->myprint("Fetching with LWP:
3401   $url
3402 ");
3403             unless ($Ua) {
3404                 CPAN::LWP::UserAgent->config;
3405                 eval { $Ua = CPAN::LWP::UserAgent->new; };
3406                 if ($@) {
3407                     $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
3408                 }
3409             }
3410             my $res = $Ua->mirror($url, $aslocal);
3411             if ($res->is_success) {
3412                 $ThesiteURL = $ro_url;
3413                 my $now = time;
3414                 utime $now, $now, $aslocal; # download time is more
3415                                             # important than upload
3416                                             # time
3417                 return $aslocal;
3418             } elsif ($url !~ /\.gz(?!\n)\Z/) {
3419                 my $gzurl = "$url.gz";
3420                 $CPAN::Frontend->myprint("Fetching with LWP:
3421   $gzurl
3422 ");
3423                 $res = $Ua->mirror($gzurl, "$aslocal.gz");
3424                 if ($res->is_success &&
3425                     CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)
3426                    ) {
3427                     $ThesiteURL = $ro_url;
3428                     return $aslocal;
3429                 }
3430             } else {
3431                 $CPAN::Frontend->myprint(sprintf(
3432                                                  "LWP failed with code[%s] message[%s]\n",
3433                                                  $res->code,
3434                                                  $res->message,
3435                                                 ));
3436                 # Alan Burlison informed me that in firewall environments
3437                 # Net::FTP can still succeed where LWP fails. So we do not
3438                 # skip Net::FTP anymore when LWP is available.
3439             }
3440         } else {
3441             $CPAN::Frontend->mywarn("  LWP not available\n");
3442         }
3443         return if $CPAN::Signal;
3444         if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3445             # that's the nice and easy way thanks to Graham
3446             $self->debug("recognized ftp") if $CPAN::DEBUG;
3447             my($host,$dir,$getfile) = ($1,$2,$3);
3448             if ($CPAN::META->has_usable('Net::FTP')) {
3449                 $dir =~ s|/+|/|g;
3450                 $CPAN::Frontend->myprint("Fetching with Net::FTP:
3451   $url
3452 ");
3453                 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
3454                              "aslocal[$aslocal]") if $CPAN::DEBUG;
3455                 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
3456                     $ThesiteURL = $ro_url;
3457                     return $aslocal;
3458                 }
3459                 if ($aslocal !~ /\.gz(?!\n)\Z/) {
3460                     my $gz = "$aslocal.gz";
3461                     $CPAN::Frontend->myprint("Fetching with Net::FTP
3462   $url.gz
3463 ");
3464                     if (CPAN::FTP->ftp_get($host,
3465                                            $dir,
3466                                            "$getfile.gz",
3467                                            $gz) &&
3468                         CPAN::Tarzip->new($gz)->gunzip($aslocal)
3469                        ){
3470                         $ThesiteURL = $ro_url;
3471                         return $aslocal;
3472                     }
3473                 }
3474                 # next HOSTEASY;
3475             } else {
3476                 CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG;
3477             }
3478         }
3479         if (
3480             UNIVERSAL::can($ro_url,"text")
3481             and
3482             $ro_url->{FROM} eq "USER"
3483            ){
3484             ##address #17973: default URLs should not try to override
3485             ##user-defined URLs just because LWP is not available
3486             my $ret = $self->hosthard([$ro_url],$file,$aslocal,$stats);
3487             return $ret if $ret;
3488         }
3489         return if $CPAN::Signal;
3490     }
3491 }
3492
3493 # package CPAN::FTP;
3494 sub hosthard {
3495   my($self,$host_seq,$file,$aslocal,$stats) = @_;
3496
3497   # Came back if Net::FTP couldn't establish connection (or
3498   # failed otherwise) Maybe they are behind a firewall, but they
3499   # gave us a socksified (or other) ftp program...
3500
3501   my($ro_url);
3502   my($devnull) = $CPAN::Config->{devnull} || "";
3503   # < /dev/null ";
3504   my($aslocal_dir) = File::Basename::dirname($aslocal);
3505   File::Path::mkpath($aslocal_dir);
3506   HOSTHARD: for $ro_url (@$host_seq) {
3507         $self->_set_attempt($stats,"hard",$ro_url);
3508         my $url = "$ro_url$file";
3509         my($proto,$host,$dir,$getfile);
3510
3511         # Courtesy Mark Conty mark_conty@cargill.com change from
3512         # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3513         # to
3514         if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
3515           # proto not yet used
3516           ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
3517         } else {
3518           next HOSTHARD; # who said, we could ftp anything except ftp?
3519         }
3520         next HOSTHARD if $proto eq "file"; # file URLs would have had
3521                                            # success above. Likely a bogus URL
3522
3523         $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
3524
3525         # Try the most capable first and leave ncftp* for last as it only
3526         # does FTP.
3527       DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
3528           my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
3529           next unless defined $funkyftp;
3530           next if $funkyftp =~ /^\s*$/;
3531
3532           my($asl_ungz, $asl_gz);
3533           ($asl_ungz = $aslocal) =~ s/\.gz//;
3534           $asl_gz = "$asl_ungz.gz";
3535
3536           my($src_switch) = "";
3537           my($chdir) = "";
3538           my($stdout_redir) = " > $asl_ungz";
3539           if ($f eq "lynx"){
3540             $src_switch = " -source";
3541           } elsif ($f eq "ncftp"){
3542             $src_switch = " -c";
3543           } elsif ($f eq "wget"){
3544             $src_switch = " -O $asl_ungz";
3545             $stdout_redir = "";
3546           } elsif ($f eq 'curl'){
3547             $src_switch = ' -L -f -s -S --netrc-optional';
3548           }
3549
3550           if ($f eq "ncftpget"){
3551             $chdir = "cd $aslocal_dir && ";
3552             $stdout_redir = "";
3553           }
3554           $CPAN::Frontend->myprint(
3555                                    qq[
3556 Trying with "$funkyftp$src_switch" to get
3557     $url
3558 ]);
3559           my($system) =
3560               "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
3561           $self->debug("system[$system]") if $CPAN::DEBUG;
3562           my($wstatus) = system($system);
3563           if ($f eq "lynx") {
3564               # lynx returns 0 when it fails somewhere
3565               if (-s $asl_ungz) {
3566                   my $content = do { local *FH;
3567                                      open FH, $asl_ungz or die;
3568                                      local $/;
3569                                      <FH> };
3570                   if ($content =~ /^<.*(<title>[45]|Error [45])/si) {
3571                       $CPAN::Frontend->mywarn(qq{
3572 No success, the file that lynx has has downloaded looks like an error message:
3573 $content
3574 });
3575                       $CPAN::Frontend->mysleep(1);
3576                       next DLPRG;
3577                   }
3578               } else {
3579                   $CPAN::Frontend->myprint(qq{
3580 No success, the file that lynx has has downloaded is an empty file.
3581 });
3582                   next DLPRG;
3583               }
3584           }
3585           if ($wstatus == 0) {
3586             if (-s $aslocal) {
3587               # Looks good
3588             } elsif ($asl_ungz ne $aslocal) {
3589               # test gzip integrity
3590               if (CPAN::Tarzip->new($asl_ungz)->gtest) {
3591                   # e.g. foo.tar is gzipped --> foo.tar.gz
3592                   rename $asl_ungz, $aslocal;
3593               } else {
3594                   CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz);
3595               }
3596             }
3597             $ThesiteURL = $ro_url;
3598             return $aslocal;
3599           } elsif ($url !~ /\.gz(?!\n)\Z/) {
3600             unlink $asl_ungz if
3601                 -f $asl_ungz && -s _ == 0;
3602             my $gz = "$aslocal.gz";
3603             my $gzurl = "$url.gz";
3604             $CPAN::Frontend->myprint(
3605                                      qq[
3606 Trying with "$funkyftp$src_switch" to get
3607   $url.gz
3608 ]);
3609             my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
3610             $self->debug("system[$system]") if $CPAN::DEBUG;
3611             my($wstatus);
3612             if (($wstatus = system($system)) == 0
3613                 &&
3614                 -s $asl_gz
3615                ) {
3616               # test gzip integrity
3617               my $ct = CPAN::Tarzip->new($asl_gz);
3618               if ($ct->gtest) {
3619                   $ct->gunzip($aslocal);
3620               } else {
3621                   # somebody uncompressed file for us?
3622                   rename $asl_ungz, $aslocal;
3623               }
3624               $ThesiteURL = $ro_url;
3625               return $aslocal;
3626             } else {
3627               unlink $asl_gz if -f $asl_gz;
3628             }
3629           } else {
3630             my $estatus = $wstatus >> 8;
3631             my $size = -f $aslocal ?
3632                 ", left\n$aslocal with size ".-s _ :
3633                     "\nWarning: expected file [$aslocal] doesn't exist";
3634             $CPAN::Frontend->myprint(qq{
3635 System call "$system"
3636 returned status $estatus (wstat $wstatus)$size
3637 });
3638           }
3639           return if $CPAN::Signal;
3640         } # transfer programs
3641     } # host
3642 }
3643
3644 # package CPAN::FTP;
3645 sub hosthardest {
3646     my($self,$host_seq,$file,$aslocal,$stats) = @_;
3647
3648     my($ro_url);
3649     my($aslocal_dir) = File::Basename::dirname($aslocal);
3650     File::Path::mkpath($aslocal_dir);
3651     my $ftpbin = $CPAN::Config->{ftp};
3652     unless ($ftpbin && length $ftpbin && MM->maybe_command($ftpbin)) {
3653         $CPAN::Frontend->myprint("No external ftp command available\n\n");
3654         return;
3655     }
3656     $CPAN::Frontend->mywarn(qq{
3657 As a last ressort we now switch to the external ftp command '$ftpbin'
3658 to get '$aslocal'.
3659
3660 Doing so often leads to problems that are hard to diagnose.
3661
3662 If you're victim of such problems, please consider unsetting the ftp
3663 config variable with
3664
3665     o conf ftp ""
3666     o conf commit
3667
3668 });
3669     $CPAN::Frontend->mysleep(2);
3670   HOSTHARDEST: for $ro_url (@$host_seq) {
3671         $self->_set_attempt($stats,"hardest",$ro_url);
3672         my $url = "$ro_url$file";
3673         $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
3674         unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3675             next;
3676         }
3677         my($host,$dir,$getfile) = ($1,$2,$3);
3678         my $timestamp = 0;
3679         my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
3680            $ctime,$blksize,$blocks) = stat($aslocal);
3681         $timestamp = $mtime ||= 0;
3682         my($netrc) = CPAN::FTP::netrc->new;
3683         my($netrcfile) = $netrc->netrc;
3684         my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
3685         my $targetfile = File::Basename::basename($aslocal);
3686         my(@dialog);
3687         push(
3688              @dialog,
3689              "lcd $aslocal_dir",
3690              "cd /",
3691              map("cd $_", split /\//, $dir), # RFC 1738
3692              "bin",
3693              "get $getfile $targetfile",
3694              "quit"
3695             );
3696         if (! $netrcfile) {
3697             CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
3698         } elsif ($netrc->hasdefault || $netrc->contains($host)) {
3699             CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
3700                                 $netrc->hasdefault,
3701                                 $netrc->contains($host))) if $CPAN::DEBUG;
3702             if ($netrc->protected) {
3703                 my $dialog = join "", map { "    $_\n" } @dialog;
3704                 my $netrc_explain;
3705                 if ($netrc->contains($host)) {
3706                     $netrc_explain = "Relying that your .netrc entry for '$host' ".
3707                         "manages the login";
3708                 } else {
3709                     $netrc_explain = "Relying that your default .netrc entry ".
3710                         "manages the login";
3711                 }
3712                 $CPAN::Frontend->myprint(qq{
3713   Trying with external ftp to get
3714     $url
3715   $netrc_explain
3716   Going to send the dialog
3717 $dialog
3718 }
3719                      );
3720                 $self->talk_ftp("$ftpbin$verbose $host",
3721                                 @dialog);
3722                 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
3723                  $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
3724                 $mtime ||= 0;
3725                 if ($mtime > $timestamp) {
3726                     $CPAN::Frontend->myprint("GOT $aslocal\n");
3727                     $ThesiteURL = $ro_url;
3728                     return $aslocal;
3729                 } else {
3730                     $CPAN::Frontend->myprint("Hmm... Still failed!\n");
3731                 }
3732                 return if $CPAN::Signal;
3733             } else {
3734                 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
3735                                         qq{correctly protected.\n});
3736             }
3737         } else {
3738             $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
3739   nor does it have a default entry\n");
3740         }
3741
3742         # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
3743         # then and login manually to host, using e-mail as
3744         # password.
3745         $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
3746         unshift(
3747                 @dialog,
3748                 "open $host",
3749                 "user anonymous $Config::Config{'cf_email'}"
3750                );
3751         my $dialog = join "", map { "    $_\n" } @dialog;
3752         $CPAN::Frontend->myprint(qq{
3753   Trying with external ftp to get
3754     $url
3755   Going to send the dialog
3756 $dialog
3757 }
3758                      );
3759         $self->talk_ftp("$ftpbin$verbose -n", @dialog);
3760         ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
3761          $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
3762         $mtime ||= 0;
3763         if ($mtime > $timestamp) {
3764             $CPAN::Frontend->myprint("GOT $aslocal\n");
3765             $ThesiteURL = $ro_url;
3766             return $aslocal;
3767         } else {
3768             $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
3769         }
3770         return if $CPAN::Signal;
3771         $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
3772         $CPAN::Frontend->mysleep(2);
3773     } # host
3774 }
3775
3776 # package CPAN::FTP;
3777 sub talk_ftp {
3778     my($self,$command,@dialog) = @_;
3779     my $fh = FileHandle->new;
3780     $fh->open("|$command") or die "Couldn't open ftp: $!";
3781     foreach (@dialog) { $fh->print("$_\n") }
3782     $fh->close;         # Wait for process to complete
3783     my $wstatus = $?;
3784     my $estatus = $wstatus >> 8;
3785     $CPAN::Frontend->myprint(qq{
3786 Subprocess "|$command"
3787   returned status $estatus (wstat $wstatus)
3788 }) if $wstatus;
3789 }
3790
3791 # find2perl needs modularization, too, all the following is stolen
3792 # from there
3793 # CPAN::FTP::ls
3794 sub ls {
3795     my($self,$name) = @_;
3796     my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
3797      $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
3798
3799     my($perms,%user,%group);
3800     my $pname = $name;
3801
3802     if ($blocks) {
3803         $blocks = int(($blocks + 1) / 2);
3804     }
3805     else {
3806         $blocks = int(($sizemm + 1023) / 1024);
3807     }
3808
3809     if    (-f _) { $perms = '-'; }
3810     elsif (-d _) { $perms = 'd'; }
3811     elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
3812     elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
3813     elsif (-p _) { $perms = 'p'; }
3814     elsif (-S _) { $perms = 's'; }
3815     else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
3816
3817     my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
3818     my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
3819     my $tmpmode = $mode;
3820     my $tmp = $rwx[$tmpmode & 7];
3821     $tmpmode >>= 3;
3822     $tmp = $rwx[$tmpmode & 7] . $tmp;
3823     $tmpmode >>= 3;
3824     $tmp = $rwx[$tmpmode & 7] . $tmp;
3825     substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
3826     substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
3827     substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
3828     $perms .= $tmp;
3829
3830     my $user = $user{$uid} || $uid;   # too lazy to implement lookup
3831     my $group = $group{$gid} || $gid;
3832
3833     my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
3834     my($timeyear);
3835     my($moname) = $moname[$mon];
3836     if (-M _ > 365.25 / 2) {
3837         $timeyear = $year + 1900;
3838     }
3839     else {
3840         $timeyear = sprintf("%02d:%02d", $hour, $min);
3841     }
3842
3843     sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
3844             $ino,
3845                  $blocks,
3846                       $perms,
3847                             $nlink,
3848                                 $user,
3849                                      $group,
3850                                           $sizemm,
3851                                               $moname,
3852                                                  $mday,
3853                                                      $timeyear,
3854                                                          $pname;
3855 }
3856
3857 package CPAN::FTP::netrc;
3858 use strict;
3859
3860 # package CPAN::FTP::netrc;
3861 sub new {
3862     my($class) = @_;
3863     my $home = CPAN::HandleConfig::home;
3864     my $file = File::Spec->catfile($home,".netrc");
3865
3866     my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
3867        $atime,$mtime,$ctime,$blksize,$blocks)
3868         = stat($file);
3869     $mode ||= 0;
3870     my $protected = 0;
3871
3872     my($fh,@machines,$hasdefault);
3873     $hasdefault = 0;
3874     $fh = FileHandle->new or die "Could not create a filehandle";
3875
3876     if($fh->open($file)){
3877         $protected = ($mode & 077) == 0;
3878         local($/) = "";
3879       NETRC: while (<$fh>) {
3880             my(@tokens) = split " ", $_;
3881           TOKEN: while (@tokens) {
3882                 my($t) = shift @tokens;
3883                 if ($t eq "default"){
3884                     $hasdefault++;
3885                     last NETRC;
3886                 }
3887                 last TOKEN if $t eq "macdef";
3888                 if ($t eq "machine") {
3889                     push @machines, shift @tokens;
3890                 }
3891             }
3892         }
3893     } else {
3894         $file = $hasdefault = $protected = "";
3895     }
3896
3897     bless {
3898            'mach' => [@machines],
3899            'netrc' => $file,
3900            'hasdefault' => $hasdefault,
3901            'protected' => $protected,
3902           }, $class;
3903 }
3904
3905 # CPAN::FTP::netrc::hasdefault;
3906 sub hasdefault { shift->{'hasdefault'} }
3907 sub netrc      { shift->{'netrc'}      }
3908 sub protected  { shift->{'protected'}  }
3909 sub contains {
3910     my($self,$mach) = @_;
3911     for ( @{$self->{'mach'}} ) {
3912         return 1 if $_ eq $mach;
3913     }
3914     return 0;
3915 }
3916
3917 package CPAN::Complete;
3918 use strict;
3919
3920 sub gnu_cpl {
3921     my($text, $line, $start, $end) = @_;
3922     my(@perlret) = cpl($text, $line, $start);
3923     # find longest common match. Can anybody show me how to peruse
3924     # T::R::Gnu to have this done automatically? Seems expensive.
3925     return () unless @perlret;
3926     my($newtext) = $text;
3927     for (my $i = length($text)+1;;$i++) {
3928         last unless length($perlret[0]) && length($perlret[0]) >= $i;
3929         my $try = substr($perlret[0],0,$i);
3930         my @tries = grep {substr($_,0,$i) eq $try} @perlret;
3931         # warn "try[$try]tries[@tries]";
3932         if (@tries == @perlret) {
3933             $newtext = $try;
3934         } else {
3935             last;
3936         }
3937     }
3938     ($newtext,@perlret);
3939 }
3940
3941 #-> sub CPAN::Complete::cpl ;
3942 sub cpl {
3943     my($word,$line,$pos) = @_;
3944     $word ||= "";
3945     $line ||= "";
3946     $pos ||= 0;
3947     CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
3948     $line =~ s/^\s*//;
3949     if ($line =~ s/^(force\s*)//) {
3950         $pos -= length($1);
3951     }
3952     my @return;
3953     if ($pos == 0) {
3954         @return = grep /^$word/, @CPAN::Complete::COMMANDS;
3955     } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
3956         @return = ();
3957     } elsif ($line =~ /^(a|ls)\s/) {
3958         @return = cplx('CPAN::Author',uc($word));
3959     } elsif ($line =~ /^b\s/) {
3960         CPAN::Shell->local_bundles;
3961         @return = cplx('CPAN::Bundle',$word);
3962     } elsif ($line =~ /^d\s/) {
3963         @return = cplx('CPAN::Distribution',$word);
3964     } elsif ($line =~ m/^(
3965                           [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
3966                          )\s/x ) {
3967         if ($word =~ /^Bundle::/) {
3968             CPAN::Shell->local_bundles;
3969         }
3970         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
3971     } elsif ($line =~ /^i\s/) {
3972         @return = cpl_any($word);
3973     } elsif ($line =~ /^reload\s/) {
3974         @return = cpl_reload($word,$line,$pos);
3975     } elsif ($line =~ /^o\s/) {
3976         @return = cpl_option($word,$line,$pos);
3977     } elsif ($line =~ m/^\S+\s/ ) {
3978         # fallback for future commands and what we have forgotten above
3979         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
3980     } else {
3981         @return = ();
3982     }
3983     return @return;
3984 }
3985
3986 #-> sub CPAN::Complete::cplx ;
3987 sub cplx {
3988     my($class, $word) = @_;
3989     # I believed for many years that this was sorted, today I
3990     # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
3991     # make it sorted again. Maybe sort was dropped when GNU-readline
3992     # support came in? The RCS file is difficult to read on that:-(
3993     sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
3994 }
3995
3996 #-> sub CPAN::Complete::cpl_any ;
3997 sub cpl_any {
3998     my($word) = shift;
3999     return (
4000             cplx('CPAN::Author',$word),
4001             cplx('CPAN::Bundle',$word),
4002             cplx('CPAN::Distribution',$word),
4003             cplx('CPAN::Module',$word),
4004            );
4005 }
4006
4007 #-> sub CPAN::Complete::cpl_reload ;
4008 sub cpl_reload {
4009     my($word,$line,$pos) = @_;
4010     $word ||= "";
4011     my(@words) = split " ", $line;
4012     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4013     my(@ok) = qw(cpan index);
4014     return @ok if @words == 1;
4015     return grep /^\Q$word\E/, @ok if @words == 2 && $word;
4016 }
4017
4018 #-> sub CPAN::Complete::cpl_option ;
4019 sub cpl_option {
4020     my($word,$line,$pos) = @_;
4021     $word ||= "";
4022     my(@words) = split " ", $line;
4023     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4024     my(@ok) = qw(conf debug);
4025     return @ok if @words == 1;
4026     return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
4027     if (0) {
4028     } elsif ($words[1] eq 'index') {
4029         return ();
4030     } elsif ($words[1] eq 'conf') {
4031         return CPAN::HandleConfig::cpl(@_);
4032     } elsif ($words[1] eq 'debug') {
4033         return sort grep /^\Q$word\E/i,
4034             sort keys %CPAN::DEBUG, 'all';
4035     }
4036 }
4037
4038 package CPAN::Index;
4039 use strict;
4040
4041 #-> sub CPAN::Index::force_reload ;
4042 sub force_reload {
4043     my($class) = @_;
4044     $CPAN::Index::LAST_TIME = 0;
4045     $class->reload(1);
4046 }
4047
4048 #-> sub CPAN::Index::reload ;
4049 sub reload {
4050     my($self,$force) = @_;
4051     my $time = time;
4052
4053     # XXX check if a newer one is available. (We currently read it
4054     # from time to time)
4055     for ($CPAN::Config->{index_expire}) {
4056         $_ = 0.001 unless $_ && $_ > 0.001;
4057     }
4058     unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
4059         # debug here when CPAN doesn't seem to read the Metadata
4060         require Carp;
4061         Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
4062     }
4063     unless ($CPAN::META->{PROTOCOL}) {
4064         $self->read_metadata_cache;
4065         $CPAN::META->{PROTOCOL} ||= "1.0";
4066     }
4067     if ( $CPAN::META->{PROTOCOL} < PROTOCOL  ) {
4068         # warn "Setting last_time to 0";
4069         $LAST_TIME = 0; # No warning necessary
4070     }
4071     if ($LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
4072         and ! $force){
4073         # called too often
4074         # CPAN->debug("LAST_TIME[$LAST_TIME]index_expire[$CPAN::Config->{index_expire}]time[$time]");
4075     } elsif (0) {
4076         # IFF we are developing, it helps to wipe out the memory
4077         # between reloads, otherwise it is not what a user expects.
4078         undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
4079         $CPAN::META = CPAN->new;
4080     } else {
4081         my($debug,$t2);
4082         local $LAST_TIME = $time;
4083         local $CPAN::META->{PROTOCOL} = PROTOCOL;
4084
4085         my $needshort = $^O eq "dos";
4086
4087         $self->rd_authindex($self
4088                           ->reload_x(
4089                                      "authors/01mailrc.txt.gz",
4090                                      $needshort ?
4091                                      File::Spec->catfile('authors', '01mailrc.gz') :
4092                                      File::Spec->catfile('authors', '01mailrc.txt.gz'),
4093                                      $force));
4094         $t2 = time;
4095         $debug = "timing reading 01[".($t2 - $time)."]";
4096         $time = $t2;
4097         return if $CPAN::Signal; # this is sometimes lengthy
4098         $self->rd_modpacks($self
4099                          ->reload_x(
4100                                     "modules/02packages.details.txt.gz",
4101                                     $needshort ?
4102                                     File::Spec->catfile('modules', '02packag.gz') :
4103                                     File::Spec->catfile('modules', '02packages.details.txt.gz'),
4104                                     $force));
4105         $t2 = time;
4106         $debug .= "02[".($t2 - $time)."]";
4107         $time = $t2;
4108         return if $CPAN::Signal; # this is sometimes lengthy
4109         $self->rd_modlist($self
4110                         ->reload_x(
4111                                    "modules/03modlist.data.gz",
4112                                    $needshort ?
4113                                    File::Spec->catfile('modules', '03mlist.gz') :
4114                                    File::Spec->catfile('modules', '03modlist.data.gz'),
4115                                    $force));
4116         $self->write_metadata_cache;
4117         $t2 = time;
4118         $debug .= "03[".($t2 - $time)."]";
4119         $time = $t2;
4120         CPAN->debug($debug) if $CPAN::DEBUG;
4121     }
4122     if ($CPAN::Config->{build_dir_reuse}) {
4123         $self->reanimate_build_dir;
4124     }
4125     $LAST_TIME = $time;
4126     $CPAN::META->{PROTOCOL} = PROTOCOL;
4127 }
4128
4129 #-> sub CPAN::Index::reanimate_build_dir ;
4130 sub reanimate_build_dir {
4131     my($self) = @_;
4132     unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module}||"YAML")) {
4133         return;
4134     }
4135     return if $HAVE_REANIMATED++;
4136     my $d = $CPAN::Config->{build_dir};
4137     my $dh = DirHandle->new;
4138     opendir $dh, $d or return; # does not exist
4139     my $dirent;
4140     my $i = 0;
4141     my $painted = 0;
4142     my $restored = 0;
4143     $CPAN::Frontend->myprint("Going to read $CPAN::Config->{build_dir}/\n");
4144     my @candidates = grep {/\.yml$/} readdir $dh;
4145   DISTRO: for $dirent (@candidates) {
4146         my $c = CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))->[0];
4147         if ($c && CPAN->_perl_fingerprint($c->{perl})) {
4148             my $key = $c->{distribution}{ID};
4149             for my $k (keys %{$c->{distribution}}) {
4150                 if ($c->{distribution}{$k}
4151                     && ref $c->{distribution}{$k}
4152                     && UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) {
4153                     # the correct algorithm would be a
4154                     # two-pass and we would subtract the
4155                     # maximum of all old commands minus 2
4156                     $c->{distribution}{$k}{COMMANDID} -= scalar @candidates - 2 ;
4157                 }
4158             }
4159
4160             #we tried to restore only if element already
4161             #exists; but then we do not work with metadata
4162             #turned off.
4163             $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key} = $c->{distribution};
4164             $restored++;
4165         }
4166         $i++;
4167         while (($painted/76) < ($i/@candidates)) {
4168             $CPAN::Frontend->myprint(".");
4169             $painted++;
4170         }
4171     }
4172     $CPAN::Frontend->myprint(sprintf(
4173                                      "DONE\nFound %s old builds, restored the state of %s\n",
4174                                      @candidates ? sprintf("%d",scalar @candidates) : "no",
4175                                      $restored || "none",
4176                                     ));
4177 }
4178
4179
4180 #-> sub CPAN::Index::reload_x ;
4181 sub reload_x {
4182     my($cl,$wanted,$localname,$force) = @_;
4183     $force |= 2; # means we're dealing with an index here
4184     CPAN::HandleConfig->load; # we should guarantee loading wherever
4185                               # we rely on Config XXX
4186     $localname ||= $wanted;
4187     my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
4188                                          $localname);
4189     if (
4190         -f $abs_wanted &&
4191         -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
4192         !($force & 1)
4193        ) {
4194         my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
4195         $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
4196                    qq{day$s. I\'ll use that.});
4197         return $abs_wanted;
4198     } else {
4199         $force |= 1; # means we're quite serious about it.
4200     }
4201     return CPAN::FTP->localize($wanted,$abs_wanted,$force);
4202 }
4203
4204 #-> sub CPAN::Index::rd_authindex ;
4205 sub rd_authindex {
4206     my($cl, $index_target) = @_;
4207     my @lines;
4208     return unless defined $index_target;
4209     $CPAN::Frontend->myprint("Going to read $index_target\n");
4210     local(*FH);
4211     tie *FH, 'CPAN::Tarzip', $index_target;
4212     local($/) = "\n";
4213     local($_);
4214     push @lines, split /\012/ while <FH>;
4215     my $i = 0;
4216     my $modulus = int($#lines/75) || 1;
4217     CPAN->debug(sprintf "modulus[%d]lines[%s]", $modulus, scalar @lines) if $CPAN::DEBUG;
4218     foreach (@lines) {
4219         my($userid,$fullname,$email) =
4220             m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/;
4221         $fullname ||= $email;
4222         if ($userid && $fullname && $email){
4223             my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
4224             $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
4225         } else {
4226             CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG;
4227         }
4228         $CPAN::Frontend->myprint(".") unless $i++ % $modulus;
4229         return if $CPAN::Signal;
4230     }
4231     $CPAN::Frontend->myprint("DONE\n");
4232 }
4233
4234 sub userid {
4235   my($self,$dist) = @_;
4236   $dist = $self->{'id'} unless defined $dist;
4237   my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
4238   $ret;
4239 }
4240
4241 #-> sub CPAN::Index::rd_modpacks ;
4242 sub rd_modpacks {
4243     my($self, $index_target) = @_;
4244     return unless defined $index_target;
4245     $CPAN::Frontend->myprint("Going to read $index_target\n");
4246     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
4247     local $_;
4248     CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
4249     my $slurp = "";
4250     my $chunk;
4251     while (my $bytes = $fh->READ(\$chunk,8192)) {
4252         $slurp.=$chunk;
4253     }
4254     my @lines = split /\012/, $slurp;
4255     CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
4256     undef $fh;
4257     # read header
4258     my($line_count,$last_updated);
4259     while (@lines) {
4260         my $shift = shift(@lines);
4261         last if $shift =~ /^\s*$/;
4262         $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
4263         $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
4264     }
4265     CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
4266     if (not defined $line_count) {
4267
4268         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
4269 Please check the validity of the index file by comparing it to more
4270 than one CPAN mirror. I'll continue but problems seem likely to
4271 happen.\a
4272 });
4273
4274         $CPAN::Frontend->mysleep(5);
4275     } elsif ($line_count != scalar @lines) {
4276
4277         $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
4278 contains a Line-Count header of %d but I see %d lines there. Please
4279 check the validity of the index file by comparing it to more than one
4280 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
4281 $index_target, $line_count, scalar(@lines));
4282
4283     }
4284     if (not defined $last_updated) {
4285
4286         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
4287 Please check the validity of the index file by comparing it to more
4288 than one CPAN mirror. I'll continue but problems seem likely to
4289 happen.\a
4290 });
4291
4292         $CPAN::Frontend->mysleep(5);
4293     } else {
4294
4295         $CPAN::Frontend
4296             ->myprint(sprintf qq{  Database was generated on %s\n},
4297                       $last_updated);
4298         $DATE_OF_02 = $last_updated;
4299
4300         my $age = time;
4301         if ($CPAN::META->has_inst('HTTP::Date')) {
4302             require HTTP::Date;
4303             $age -= HTTP::Date::str2time($last_updated);
4304         } else {
4305             $CPAN::Frontend->mywarn("  HTTP::Date not available\n");
4306             require Time::Local;
4307             my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
4308             $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
4309             $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
4310         }
4311         $age /= 3600*24;
4312         if ($age > 30) {
4313
4314             $CPAN::Frontend
4315                 ->mywarn(sprintf
4316                          qq{Warning: This index file is %d days old.
4317   Please check the host you chose as your CPAN mirror for staleness.
4318   I'll continue but problems seem likely to happen.\a\n},
4319                          $age);
4320
4321         } elsif ($age < -1) {
4322
4323             $CPAN::Frontend
4324                 ->mywarn(sprintf
4325                          qq{Warning: Your system date is %d days behind this index file!
4326   System time:          %s
4327   Timestamp index file: %s
4328   Please fix your system time, problems with the make command expected.\n},
4329                          -$age,
4330                          scalar gmtime,
4331                          $DATE_OF_02,
4332                         );
4333
4334         }
4335     }
4336
4337
4338     # A necessity since we have metadata_cache: delete what isn't
4339     # there anymore
4340     my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
4341     CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
4342     my(%exists);
4343     my $i = 0;
4344     my $modulus = int($#lines/75) || 1;
4345     foreach (@lines) {
4346         # before 1.56 we split into 3 and discarded the rest. From
4347         # 1.57 we assign remaining text to $comment thus allowing to
4348         # influence isa_perl
4349         my($mod,$version,$dist,$comment) = split " ", $_, 4;
4350         my($bundle,$id,$userid);
4351
4352         if ($mod eq 'CPAN' &&
4353             ! (
4354                CPAN::Queue->exists('Bundle::CPAN') ||
4355                CPAN::Queue->exists('CPAN')
4356               )
4357            ) {
4358             local($^W)= 0;
4359             if ($version > $CPAN::VERSION){
4360                 $CPAN::Frontend->mywarn(qq{
4361   New CPAN.pm version (v$version) available.
4362   [Currently running version is v$CPAN::VERSION]
4363   You might want to try
4364     install CPAN
4365     reload cpan
4366   to both upgrade CPAN.pm and run the new version without leaving
4367   the current session.
4368
4369 }); #});
4370                 $CPAN::Frontend->mysleep(2);
4371                 $CPAN::Frontend->myprint(qq{\n});
4372             }
4373             last if $CPAN::Signal;
4374         } elsif ($mod =~ /^Bundle::(.*)/) {
4375             $bundle = $1;
4376         }
4377
4378         if ($bundle){
4379             $id =  $CPAN::META->instance('CPAN::Bundle',$mod);
4380             # Let's make it a module too, because bundles have so much
4381             # in common with modules.
4382
4383             # Changed in 1.57_63: seems like memory bloat now without
4384             # any value, so commented out
4385
4386             # $CPAN::META->instance('CPAN::Module',$mod);
4387
4388         } else {
4389
4390             # instantiate a module object
4391             $id = $CPAN::META->instance('CPAN::Module',$mod);
4392
4393         }
4394
4395         # Although CPAN prohibits same name with different version the
4396         # indexer may have changed the version for the same distro
4397         # since the last time ("Force Reindexing" feature)
4398         if ($id->cpan_file ne $dist
4399             ||
4400             $id->cpan_version ne $version
4401            ){
4402             $userid = $id->userid || $self->userid($dist);
4403             $id->set(
4404                      'CPAN_USERID' => $userid,
4405                      'CPAN_VERSION' => $version,
4406                      'CPAN_FILE' => $dist,
4407                     );
4408         }
4409
4410         # instantiate a distribution object
4411         if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
4412           # we do not need CONTAINSMODS unless we do something with
4413           # this dist, so we better produce it on demand.
4414
4415           ## my $obj = $CPAN::META->instance(
4416           ##                              'CPAN::Distribution' => $dist
4417           ##                             );
4418           ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
4419         } else {
4420           $CPAN::META->instance(
4421                                 'CPAN::Distribution' => $dist
4422                                )->set(
4423                                       'CPAN_USERID' => $userid,
4424                                       'CPAN_COMMENT' => $comment,
4425                                      );
4426         }
4427         if ($secondtime) {
4428             for my $name ($mod,$dist) {
4429                 # $self->debug("exists name[$name]") if $CPAN::DEBUG;
4430                 $exists{$name} = undef;
4431             }
4432         }
4433         $CPAN::Frontend->myprint(".") unless $i++ % $modulus;
4434         return if $CPAN::Signal;
4435     }
4436     $CPAN::Frontend->myprint("DONE\n");
4437     if ($secondtime) {
4438         for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
4439             for my $o ($CPAN::META->all_objects($class)) {
4440                 next if exists $exists{$o->{ID}};
4441                 $CPAN::META->delete($class,$o->{ID});
4442                 # CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
4443                 #     if $CPAN::DEBUG;
4444             }
4445         }
4446     }
4447 }
4448
4449 #-> sub CPAN::Index::rd_modlist ;
4450 sub rd_modlist {
4451     my($cl,$index_target) = @_;
4452     return unless defined $index_target;
4453     $CPAN::Frontend->myprint("Going to read $index_target\n");
4454     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
4455     local $_;
4456     my $slurp = "";
4457     my $chunk;
4458     while (my $bytes = $fh->READ(\$chunk,8192)) {
4459         $slurp.=$chunk;
4460     }
4461     my @eval2 = split /\012/, $slurp;
4462
4463     while (@eval2) {
4464         my $shift = shift(@eval2);
4465         if ($shift =~ /^Date:\s+(.*)/){
4466             if ($DATE_OF_03 eq $1){
4467                 $CPAN::Frontend->myprint("Unchanged.\n");
4468                 return;
4469             }
4470             ($DATE_OF_03) = $1;
4471         }
4472         last if $shift =~ /^\s*$/;
4473     }
4474     push @eval2, q{CPAN::Modulelist->data;};
4475     local($^W) = 0;
4476     my($comp) = Safe->new("CPAN::Safe1");
4477     my($eval2) = join("\n", @eval2);
4478     CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG;
4479     my $ret = $comp->reval($eval2);
4480     Carp::confess($@) if $@;
4481     return if $CPAN::Signal;
4482     my $i = 0;
4483     my $until = keys(%$ret) - 1;
4484     my $modulus = int($until/75) || 1;
4485     CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
4486     for (keys %$ret) {
4487         my $obj = $CPAN::META->instance("CPAN::Module",$_);
4488         delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
4489         $obj->set(%{$ret->{$_}});
4490         $CPAN::Frontend->myprint(".") unless $i++ % $modulus;
4491         return if $CPAN::Signal;
4492     }
4493     $CPAN::Frontend->myprint("DONE\n");
4494 }
4495
4496 #-> sub CPAN::Index::write_metadata_cache ;
4497 sub write_metadata_cache {
4498     my($self) = @_;
4499     return unless $CPAN::Config->{'cache_metadata'};
4500     return unless $CPAN::META->has_usable("Storable");
4501     my $cache;
4502     foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
4503                       CPAN::Distribution)) {
4504         $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
4505     }
4506     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
4507     $cache->{last_time} = $LAST_TIME;
4508     $cache->{DATE_OF_02} = $DATE_OF_02;
4509     $cache->{PROTOCOL} = PROTOCOL;
4510     $CPAN::Frontend->myprint("Going to write $metadata_file\n");
4511     eval { Storable::nstore($cache, $metadata_file) };
4512     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
4513 }
4514
4515 #-> sub CPAN::Index::read_metadata_cache ;
4516 sub read_metadata_cache {
4517     my($self) = @_;
4518     return unless $CPAN::Config->{'cache_metadata'};
4519     return unless $CPAN::META->has_usable("Storable");
4520     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
4521     return unless -r $metadata_file and -f $metadata_file;
4522     $CPAN::Frontend->myprint("Going to read $metadata_file\n");
4523     my $cache;
4524     eval { $cache = Storable::retrieve($metadata_file) };
4525     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
4526     if (!$cache || !UNIVERSAL::isa($cache, 'HASH')){
4527         $LAST_TIME = 0;
4528         return;
4529     }
4530     if (exists $cache->{PROTOCOL}) {
4531         if (PROTOCOL > $cache->{PROTOCOL}) {
4532             $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
4533                                             "with protocol v%s, requiring v%s\n",
4534                                             $cache->{PROTOCOL},
4535                                             PROTOCOL)
4536                                    );
4537             return;
4538         }
4539     } else {
4540         $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
4541                                 "with protocol v1.0\n");
4542         return;
4543     }
4544     my $clcnt = 0;
4545     my $idcnt = 0;
4546     while(my($class,$v) = each %$cache) {
4547         next unless $class =~ /^CPAN::/;
4548         $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
4549         while (my($id,$ro) = each %$v) {
4550             $CPAN::META->{readwrite}{$class}{$id} ||=
4551                 $class->new(ID=>$id, RO=>$ro);
4552             $idcnt++;
4553         }
4554         $clcnt++;
4555     }
4556     unless ($clcnt) { # sanity check
4557         $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
4558         return;
4559     }
4560     if ($idcnt < 1000) {
4561         $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
4562                                  "in $metadata_file\n");
4563         return;
4564     }
4565     $CPAN::META->{PROTOCOL} ||=
4566         $cache->{PROTOCOL}; # reading does not up or downgrade, but it
4567                             # does initialize to some protocol
4568     $LAST_TIME = $cache->{last_time};
4569     $DATE_OF_02 = $cache->{DATE_OF_02};
4570     $CPAN::Frontend->myprint("  Database was generated on $DATE_OF_02\n")
4571         if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
4572     return;
4573 }
4574
4575 package CPAN::InfoObj;
4576 use strict;
4577
4578 sub ro {
4579     my $self = shift;
4580     exists $self->{RO} and return $self->{RO};
4581 }
4582
4583 #-> sub CPAN::InfoObj::cpan_userid
4584 sub cpan_userid {
4585     my $self = shift;
4586     my $ro = $self->ro;
4587     if ($ro) {
4588         return $ro->{CPAN_USERID} || "N/A";
4589     } else {
4590         $self->debug("ID[$self->{ID}]");
4591         # N/A for bundles found locally
4592         return "N/A";
4593     }
4594 }
4595
4596 sub id { shift->{ID}; }
4597
4598 #-> sub CPAN::InfoObj::new ;
4599 sub new {
4600     my $this = bless {}, shift;
4601     %$this = @_;
4602     $this
4603 }
4604
4605 # The set method may only be used by code that reads index data or
4606 # otherwise "objective" data from the outside world. All session
4607 # related material may do anything else with instance variables but
4608 # must not touch the hash under the RO attribute. The reason is that
4609 # the RO hash gets written to Metadata file and is thus persistent.
4610
4611 #-> sub CPAN::InfoObj::safe_chdir ;
4612 sub safe_chdir {
4613   my($self,$todir) = @_;
4614   # we die if we cannot chdir and we are debuggable
4615   Carp::confess("safe_chdir called without todir argument")
4616         unless defined $todir and length $todir;
4617   if (chdir $todir) {
4618     $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
4619         if $CPAN::DEBUG;
4620   } else {
4621     if (-e $todir) {
4622         unless (-x $todir) {
4623             unless (chmod 0755, $todir) {
4624                 my $cwd = CPAN::anycwd();
4625                 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
4626                                         "permission to change the permission; cannot ".
4627                                         "chdir to '$todir'\n");
4628                 $CPAN::Frontend->mysleep(5);
4629                 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
4630                                        qq{to todir[$todir]: $!});
4631             }
4632         }
4633     } else {
4634         $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n");
4635     }
4636     if (chdir $todir) {
4637       $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
4638           if $CPAN::DEBUG;
4639     } else {
4640       my $cwd = CPAN::anycwd();
4641       $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
4642                              qq{to todir[$todir] (a chmod has been issued): $!});
4643     }
4644   }
4645 }
4646
4647 #-> sub CPAN::InfoObj::set ;
4648 sub set {
4649     my($self,%att) = @_;
4650     my $class = ref $self;
4651
4652     # This must be ||=, not ||, because only if we write an empty
4653     # reference, only then the set method will write into the readonly
4654     # area. But for Distributions that spring into existence, maybe
4655     # because of a typo, we do not like it that they are written into
4656     # the readonly area and made permanent (at least for a while) and
4657     # that is why we do not "allow" other places to call ->set.
4658     unless ($self->id) {
4659         CPAN->debug("Bug? Empty ID, rejecting");
4660         return;
4661     }
4662     my $ro = $self->{RO} =
4663         $CPAN::META->{readonly}{$class}{$self->id} ||= {};
4664
4665     while (my($k,$v) = each %att) {
4666         $ro->{$k} = $v;
4667     }
4668 }
4669
4670 #-> sub CPAN::InfoObj::as_glimpse ;
4671 sub as_glimpse {
4672     my($self) = @_;
4673     my(@m);
4674     my $class = ref($self);
4675     $class =~ s/^CPAN:://;
4676     my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID};
4677     push @m, sprintf "%-15s %s\n", $class, $id;
4678     join "", @m;
4679 }
4680
4681 #-> sub CPAN::InfoObj::as_string ;
4682 sub as_string {
4683     my($self) = @_;
4684     my(@m);
4685     my $class = ref($self);
4686     $class =~ s/^CPAN:://;
4687     push @m, $class, " id = $self->{ID}\n";
4688     my $ro;
4689     unless ($ro = $self->ro) {
4690         if (substr($self->{ID},-1,1) eq ".") { # directory
4691             $ro = +{};
4692         } else {
4693             $CPAN::Frontend->mydie("Unknown object $self->{ID}");
4694         }
4695     }
4696     for (sort keys %$ro) {
4697         # next if m/^(ID|RO)$/;
4698         my $extra = "";
4699         if ($_ eq "CPAN_USERID") {
4700             $extra .= " (";
4701             $extra .= $self->fullname;
4702             my $email; # old perls!
4703             if ($email = $CPAN::META->instance("CPAN::Author",
4704                                                $self->cpan_userid
4705                                               )->email) {
4706                 $extra .= " <$email>";
4707             } else {
4708                 $extra .= " <no email>";
4709             }
4710             $extra .= ")";
4711         } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
4712             push @m, sprintf "    %-12s %s\n", $_, $self->fullname;
4713             next;
4714         }
4715         next unless defined $ro->{$_};
4716         push @m, sprintf "    %-12s %s%s\n", $_, $ro->{$_}, $extra;
4717     }
4718   KEY: for (sort keys %$self) {
4719         next if m/^(ID|RO)$/;
4720         unless (defined $self->{$_}) {
4721             delete $self->{$_};
4722             next KEY;
4723         }
4724         if (ref($self->{$_}) eq "ARRAY") {
4725           push @m, sprintf "    %-12s %s\n", $_, "@{$self->{$_}}";
4726         } elsif (ref($self->{$_}) eq "HASH") {
4727             my $value;
4728             if (/^CONTAINSMODS$/) {
4729                 $value = join(" ",sort keys %{$self->{$_}});
4730             } elsif (/^prereq_pm$/) {
4731                 my @value;
4732                 my $v = $self->{$_};
4733                 for my $x (sort keys %$v) {
4734                     my @svalue;
4735                     for my $y (sort keys %{$v->{$x}}) {
4736                         push @svalue, "$y=>$v->{$x}{$y}";
4737                     }
4738                     push @value, "$x\:" . join ",", @svalue if @svalue;
4739                 }
4740                 $value = join ";", @value;
4741             } else {
4742                 $value = $self->{$_};
4743             }
4744           push @m, sprintf(
4745                            "    %-12s %s\n",
4746                            $_,
4747                            $value,
4748                           );
4749         } else {
4750           push @m, sprintf "    %-12s %s\n", $_, $self->{$_};
4751         }
4752     }
4753     join "", @m, "\n";
4754 }
4755
4756 #-> sub CPAN::InfoObj::fullname ;
4757 sub fullname {
4758     my($self) = @_;
4759     $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
4760 }
4761
4762 #-> sub CPAN::InfoObj::dump ;
4763 sub dump {
4764   my($self, $what) = @_;
4765   unless ($CPAN::META->has_inst("Data::Dumper")) {
4766       $CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
4767   }
4768   local $Data::Dumper::Sortkeys;
4769   $Data::Dumper::Sortkeys = 1;
4770   my $out = Data::Dumper::Dumper($what ? eval $what : $self);
4771   if (length $out > 100000) {
4772       my $fh_pager = FileHandle->new;
4773       local($SIG{PIPE}) = "IGNORE";
4774       my $pager = $CPAN::Config->{'pager'} || "cat";
4775       $fh_pager->open("|$pager")
4776           or die "Could not open pager $pager\: $!";
4777       $fh_pager->print($out);
4778       close $fh_pager;
4779   } else {
4780       $CPAN::Frontend->myprint($out);
4781   }
4782 }
4783
4784 package CPAN::Author;
4785 use strict;
4786
4787 #-> sub CPAN::Author::force
4788 sub force {
4789     my $self = shift;
4790     $self->{force}++;
4791 }
4792
4793 #-> sub CPAN::Author::force
4794 sub unforce {
4795     my $self = shift;
4796     delete $self->{force};
4797 }
4798
4799 #-> sub CPAN::Author::id
4800 sub id {
4801     my $self = shift;
4802     my $id = $self->{ID};
4803     $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
4804     $id;
4805 }
4806
4807 #-> sub CPAN::Author::as_glimpse ;
4808 sub as_glimpse {
4809     my($self) = @_;
4810     my(@m);
4811     my $class = ref($self);
4812     $class =~ s/^CPAN:://;
4813     push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
4814                      $class,
4815                      $self->{ID},
4816                      $self->fullname,
4817                      $self->email);
4818     join "", @m;
4819 }
4820
4821 #-> sub CPAN::Author::fullname ;
4822 sub fullname {
4823     shift->ro->{FULLNAME};
4824 }
4825 *name = \&fullname;
4826
4827 #-> sub CPAN::Author::email ;
4828 sub email    { shift->ro->{EMAIL}; }
4829
4830 #-> sub CPAN::Author::ls ;
4831 sub ls {
4832     my $self = shift;
4833     my $glob = shift || "";
4834     my $silent = shift || 0;
4835     my $id = $self->id;
4836
4837     # adapted from CPAN::Distribution::verifyCHECKSUM ;
4838     my(@csf); # chksumfile
4839     @csf = $self->id =~ /(.)(.)(.*)/;
4840     $csf[1] = join "", @csf[0,1];
4841     $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
4842     my(@dl);
4843     @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
4844     unless (grep {$_->[2] eq $csf[1]} @dl) {
4845         $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
4846         return;
4847     }
4848     @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
4849     unless (grep {$_->[2] eq $csf[2]} @dl) {
4850         $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
4851         return;
4852     }
4853     @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
4854     if ($glob) {
4855         if ($CPAN::META->has_inst("Text::Glob")) {
4856             my $rglob = Text::Glob::glob_to_regex($glob);
4857             @dl = grep { $_->[2] =~ /$rglob/ } @dl;
4858         } else {
4859             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
4860         }
4861     }
4862     $CPAN::Frontend->myprint(join "", map {
4863         sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
4864     } sort { $a->[2] cmp $b->[2] } @dl);
4865     @dl;
4866 }
4867
4868 # returns an array of arrays, the latter contain (size,mtime,filename)
4869 #-> sub CPAN::Author::dir_listing ;
4870 sub dir_listing {
4871     my $self = shift;
4872     my $chksumfile = shift;
4873     my $recursive = shift;
4874     my $may_ftp = shift;
4875
4876     my $lc_want =
4877         File::Spec->catfile($CPAN::Config->{keep_source_where},
4878                             "authors", "id", @$chksumfile);
4879
4880     my $fh;
4881
4882     # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
4883     # hazard.  (Without GPG installed they are not that much better,
4884     # though.)
4885     $fh = FileHandle->new;
4886     if (open($fh, $lc_want)) {
4887         my $line = <$fh>; close $fh;
4888         unlink($lc_want) unless $line =~ /PGP/;
4889     }
4890
4891     local($") = "/";
4892     # connect "force" argument with "index_expire".
4893     my $force = $self->{force};
4894     if (my @stat = stat $lc_want) {
4895         $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
4896     }
4897     my $lc_file;
4898     if ($may_ftp) {
4899         $lc_file = CPAN::FTP->localize(
4900                                        "authors/id/@$chksumfile",
4901                                        $lc_want,
4902                                        $force,
4903                                       );
4904         unless ($lc_file) {
4905             $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
4906             $chksumfile->[-1] .= ".gz";
4907             $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
4908                                            "$lc_want.gz",1);
4909             if ($lc_file) {
4910                 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
4911                 CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file);
4912             } else {
4913                 return;
4914             }
4915         }
4916     } else {
4917         $lc_file = $lc_want;
4918         # we *could* second-guess and if the user has a file: URL,
4919         # then we could look there. But on the other hand, if they do
4920         # have a file: URL, wy did they choose to set
4921         # $CPAN::Config->{show_upload_date} to false?
4922     }
4923
4924     # adapted from CPAN::Distribution::CHECKSUM_check_file ;
4925     $fh = FileHandle->new;
4926     my($cksum);
4927     if (open $fh, $lc_file){
4928         local($/);
4929         my $eval = <$fh>;
4930         $eval =~ s/\015?\012/\n/g;
4931         close $fh;
4932         my($comp) = Safe->new();
4933         $cksum = $comp->reval($eval);
4934         if ($@) {
4935             rename $lc_file, "$lc_file.bad";
4936             Carp::confess($@) if $@;
4937         }
4938     } elsif ($may_ftp) {
4939         Carp::carp "Could not open '$lc_file' for reading.";
4940     } else {
4941         # Maybe should warn: "You may want to set show_upload_date to a true value"
4942         return;
4943     }
4944     my(@result,$f);
4945     for $f (sort keys %$cksum) {
4946         if (exists $cksum->{$f}{isdir}) {
4947             if ($recursive) {
4948                 my(@dir) = @$chksumfile;
4949                 pop @dir;
4950                 push @dir, $f, "CHECKSUMS";
4951                 push @result, map {
4952                     [$_->[0], $_->[1], "$f/$_->[2]"]
4953                 } $self->dir_listing(\@dir,1,$may_ftp);
4954             } else {
4955                 push @result, [ 0, "-", $f ];
4956             }
4957         } else {
4958             push @result, [
4959                            ($cksum->{$f}{"size"}||0),
4960                            $cksum->{$f}{"mtime"}||"---",
4961                            $f
4962                           ];
4963         }
4964     }
4965     @result;
4966 }
4967
4968 package CPAN::Distribution;
4969 use strict;
4970
4971 # Accessors
4972 sub cpan_comment {
4973     my $self = shift;
4974     my $ro = $self->ro or return;
4975     $ro->{CPAN_COMMENT}
4976 }
4977
4978 # CPAN::Distribution::undelay
4979 sub undelay {
4980     my $self = shift;
4981     delete $self->{later};
4982 }
4983
4984 # add the A/AN/ stuff
4985 # CPAN::Distribution::normalize
4986 sub normalize {
4987     my($self,$s) = @_;
4988     $s = $self->id unless defined $s;
4989     if (substr($s,-1,1) eq ".") {
4990         # using a global because we are sometimes called as static method
4991         if (!$CPAN::META->{LOCK}
4992             && !$CPAN::Have_warned->{"$s is unlocked"}++
4993            ) {
4994             $CPAN::Frontend->mywarn("You are visiting the local directory
4995   '$s'
4996   without lock, take care that concurrent processes do not do likewise.\n");
4997             $CPAN::Frontend->mysleep(1);
4998         }
4999         if ($s eq ".") {
5000             $s = "$CPAN::iCwd/.";
5001         } elsif (File::Spec->file_name_is_absolute($s)) {
5002         } elsif (File::Spec->can("rel2abs")) {
5003             $s = File::Spec->rel2abs($s);
5004         } else {
5005             $CPAN::Frontend->mydie("Your File::Spec is too old, please upgrade File::Spec");
5006         }
5007         CPAN->debug("s[$s]") if $CPAN::DEBUG;
5008         unless ($CPAN::META->exists("CPAN::Distribution", $s)) {
5009             for ($CPAN::META->instance("CPAN::Distribution", $s)) {
5010                 $_->{build_dir} = $s;
5011                 $_->{archived} = "local_directory";
5012                 $_->{unwrapped} = CPAN::Distrostatus->new("YES -- local_directory");
5013             }
5014         }
5015     } elsif (
5016         $s =~ tr|/|| == 1
5017         or
5018         $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
5019        ) {
5020         return $s if $s =~ m:^N/A|^Contact Author: ;
5021         $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
5022             $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
5023         CPAN->debug("s[$s]") if $CPAN::DEBUG;
5024     }
5025     $s;
5026 }
5027
5028 #-> sub CPAN::Distribution::author ;
5029 sub author {
5030     my($self) = @_;
5031     my($authorid);
5032     if (substr($self->id,-1,1) eq ".") {
5033         $authorid = "LOCAL";
5034     } else {
5035         ($authorid) = $self->pretty_id =~ /^([\w\-]+)/;
5036     }
5037     CPAN::Shell->expand("Author",$authorid);
5038 }
5039
5040 # tries to get the yaml from CPAN instead of the distro itself:
5041 # EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels
5042 sub fast_yaml {
5043     my($self) = @_;
5044     my $meta = $self->pretty_id;
5045     $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/;
5046     my(@ls) = CPAN::Shell->globls($meta);
5047     my $norm = $self->normalize($meta);
5048
5049     my($local_file);
5050     my($local_wanted) =
5051         File::Spec->catfile(
5052                             $CPAN::Config->{keep_source_where},
5053                             "authors",
5054                             "id",
5055                             split(/\//,$norm)
5056                            );
5057     $self->debug("Doing localize") if $CPAN::DEBUG;
5058     unless ($local_file =
5059             CPAN::FTP->localize("authors/id/$norm",
5060                                 $local_wanted)) {
5061         $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n");
5062     }
5063     my $yaml = CPAN->_yaml_loadfile($local_file)->[0];
5064 }
5065
5066 #-> sub CPAN::Distribution::cpan_userid
5067 sub cpan_userid {
5068     my $self = shift;
5069     if ($self->{ID} =~ m{[A-Z]/[A-Z\-]{2}/([A-Z\-]+)/}) {
5070         return $1;
5071     }
5072     return $self->SUPER::cpan_userid;
5073 }
5074
5075 #-> sub CPAN::Distribution::pretty_id
5076 sub pretty_id {
5077     my $self = shift;
5078     my $id = $self->id;
5079     return $id unless $id =~ m|^./../|;
5080     substr($id,5);
5081 }
5082
5083 # mark as dirty/clean
5084 #-> sub CPAN::Distribution::color_cmd_tmps ;
5085 sub color_cmd_tmps {
5086     my($self) = shift;
5087     my($depth) = shift || 0;
5088     my($color) = shift || 0;
5089     my($ancestors) = shift || [];
5090     # a distribution needs to recurse into its prereq_pms
5091
5092     return if exists $self->{incommandcolor}
5093         && $self->{incommandcolor}==$color;
5094     if ($depth>=100){
5095         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
5096     }
5097     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5098     my $prereq_pm = $self->prereq_pm;
5099     if (defined $prereq_pm) {
5100       PREREQ: for my $pre (keys %{$prereq_pm->{requires}||{}},
5101                            keys %{$prereq_pm->{build_requires}||{}}) {
5102             next PREREQ if $pre eq "perl";
5103             my $premo;
5104             unless ($premo = CPAN::Shell->expand("Module",$pre)) {
5105                 $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n");
5106                 $CPAN::Frontend->mysleep(2);
5107                 next PREREQ;
5108             }
5109             $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5110         }
5111     }
5112     if ($color==0) {
5113         delete $self->{sponsored_mods};
5114         delete $self->{badtestcnt};
5115     }
5116     $self->{incommandcolor} = $color;
5117 }
5118
5119 #-> sub CPAN::Distribution::as_string ;
5120 sub as_string {
5121   my $self = shift;
5122   $self->containsmods;
5123   $self->upload_date;
5124   $self->SUPER::as_string(@_);
5125 }
5126
5127 #-> sub CPAN::Distribution::containsmods ;
5128 sub containsmods {
5129   my $self = shift;
5130   return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
5131   my $dist_id = $self->{ID};
5132   for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
5133     my $mod_file = $mod->cpan_file or next;
5134     my $mod_id = $mod->{ID} or next;
5135     # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
5136     # sleep 1;
5137     $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
5138   }
5139   keys %{$self->{CONTAINSMODS}};
5140 }
5141
5142 #-> sub CPAN::Distribution::upload_date ;
5143 sub upload_date {
5144   my $self = shift;
5145   return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
5146   my(@local_wanted) = split(/\//,$self->id);
5147   my $filename = pop @local_wanted;
5148   push @local_wanted, "CHECKSUMS";
5149   my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
5150   return unless $author;
5151   my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
5152   return unless @dl;
5153   my($dirent) = grep { $_->[2] eq $filename } @dl;
5154   # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
5155   return unless $dirent->[1];
5156   return $self->{UPLOAD_DATE} = $dirent->[1];
5157 }
5158
5159 #-> sub CPAN::Distribution::uptodate ;
5160 sub uptodate {
5161     my($self) = @_;
5162     my $c;
5163     foreach $c ($self->containsmods) {
5164         my $obj = CPAN::Shell->expandany($c);
5165         unless ($obj->uptodate){
5166             my $id = $self->pretty_id;
5167             $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG;
5168             return 0;
5169         }
5170     }
5171     return 1;
5172 }
5173
5174 #-> sub CPAN::Distribution::called_for ;
5175 sub called_for {
5176     my($self,$id) = @_;
5177     $self->{CALLED_FOR} = $id if defined $id;
5178     return $self->{CALLED_FOR};
5179 }
5180
5181 #-> sub CPAN::Distribution::get ;
5182 sub get {
5183     my($self) = @_;
5184     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
5185                            ? $ENV{PERL5LIB}
5186                            : ($ENV{PERLLIB} || "");
5187
5188     $CPAN::META->set_perl5lib;
5189     local $ENV{MAKEFLAGS}; # protect us from outer make calls
5190
5191   EXCUSE: {
5192         my @e;
5193         if ($self->prefs->{disabled}) {
5194             push @e, sprintf(
5195                              "disabled via prefs file '%s' doc %d",
5196                              $self->{prefs_file},
5197                              $self->{prefs_file_doc},
5198                             );
5199         }
5200         exists $self->{build_dir} and push @e,
5201             "Is already unwrapped into directory $self->{build_dir}";
5202
5203         exists $self->{unwrapped} and (
5204                                        $self->{unwrapped}->can("failed") ?
5205                                        $self->{unwrapped}->failed :
5206                                        $self->{unwrapped} =~ /^NO/
5207                                       )
5208             and push @e, "Unwrapping had some problem, won't try again without force";
5209
5210         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
5211     }
5212     my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
5213
5214     #
5215     # Get the file on local disk
5216     #
5217
5218     my($local_file);
5219     my($local_wanted) =
5220         File::Spec->catfile(
5221                             $CPAN::Config->{keep_source_where},
5222                             "authors",
5223                             "id",
5224                             split(/\//,$self->id)
5225                            );
5226
5227     $self->debug("Doing localize") if $CPAN::DEBUG;
5228     unless ($local_file =
5229             CPAN::FTP->localize("authors/id/$self->{ID}",
5230                                 $local_wanted)) {
5231         my $note = "";
5232         if ($CPAN::Index::DATE_OF_02) {
5233             $note = "Note: Current database in memory was generated ".
5234                 "on $CPAN::Index::DATE_OF_02\n";
5235         }
5236         $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
5237     }
5238
5239     $self->debug("local_wanted[$local_wanted]local_file[$local_file]") if $CPAN::DEBUG;
5240     $self->{localfile} = $local_file;
5241     return if $CPAN::Signal;
5242
5243     #
5244     # Check integrity
5245     #
5246     if ($CPAN::META->has_inst("Digest::SHA")) {
5247         $self->debug("Digest::SHA is installed, verifying");
5248         $self->verifyCHECKSUM;
5249     } else {
5250         $self->debug("Digest::SHA is NOT installed");
5251     }
5252     return if $CPAN::Signal;
5253
5254     #
5255     # Create a clean room and go there
5256     #
5257     $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
5258     my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
5259     $self->safe_chdir($builddir);
5260     $self->debug("Removing tmp-$$") if $CPAN::DEBUG;
5261     File::Path::rmtree("tmp-$$");
5262     unless (mkdir "tmp-$$", 0755) {
5263         $CPAN::Frontend->unrecoverable_error(<<EOF);
5264 Couldn't mkdir '$builddir/tmp-$$': $!
5265
5266 Cannot continue: Please find the reason why I cannot make the
5267 directory
5268 $builddir/tmp-$$
5269 and fix the problem, then retry.
5270
5271 EOF
5272     }
5273     if ($CPAN::Signal){
5274         $self->safe_chdir($sub_wd);
5275         return;
5276     }
5277     $self->safe_chdir("tmp-$$");
5278
5279     #
5280     # Unpack the goods
5281     #
5282     my $ct = CPAN::Tarzip->new($local_file);
5283     if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i){
5284         $self->{was_uncompressed}++ unless $ct->gtest();
5285         $self->untar_me($ct);
5286     } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
5287         $self->unzip_me($ct);
5288     } else {
5289         $self->{was_uncompressed}++ unless $ct->gtest();
5290         $local_file = $self->handle_singlefile($local_file);
5291 #    } else {
5292 #       $self->{archived} = "NO";
5293 #        $self->safe_chdir($sub_wd);
5294 #        return;
5295     }
5296
5297     # we are still in the tmp directory!
5298     # Let's check if the package has its own directory.
5299     my $dh = DirHandle->new(File::Spec->curdir)
5300         or Carp::croak("Couldn't opendir .: $!");
5301     my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
5302     $dh->close;
5303     my ($packagedir);
5304     # XXX here we want in each branch File::Temp to protect all build_dir directories
5305     if (CPAN->has_inst("File::Temp")) {
5306         my $tdir_base;
5307         my $from_dir;
5308         my @dirents;
5309         if (@readdir == 1 && -d $readdir[0]) {
5310             $tdir_base = $readdir[0];
5311             $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]);
5312             my $dh2 = DirHandle->new($from_dir)
5313                 or Carp::croak("Couldn't opendir $from_dir: $!");
5314             @dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC??
5315         } else {
5316             my $userid = $self->cpan_userid;
5317             CPAN->debug("userid[$userid]");
5318             if (!$userid or $userid eq "N/A") {
5319                 $userid = "anon";
5320             }
5321             $tdir_base = $userid;
5322             $from_dir = File::Spec->curdir;
5323             @dirents = @readdir;
5324         }
5325         $packagedir = File::Temp::tempdir(
5326                                           "$tdir_base-XXXXXX",
5327                                           DIR => $builddir,
5328                                           CLEANUP => 0,
5329                                          );
5330         my $f;
5331         for $f (@dirents) { # is already without "." and ".."
5332             my $from = File::Spec->catdir($from_dir,$f);
5333             my $to = File::Spec->catdir($packagedir,$f);
5334             File::Copy::move($from,$to) or Carp::confess("Couldn't move $from to $to: $!");
5335         }
5336     } else { # older code below, still better than nothing when there is no File::Temp
5337         my($distdir);
5338         if (@readdir == 1 && -d $readdir[0]) {
5339             $distdir = $readdir[0];
5340             $packagedir = File::Spec->catdir($builddir,$distdir);
5341             $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
5342                 if $CPAN::DEBUG;
5343             -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
5344                                                         "$packagedir\n");
5345             File::Path::rmtree($packagedir);
5346             unless (File::Copy::move($distdir,$packagedir)) {
5347                 $CPAN::Frontend->unrecoverable_error(<<EOF);
5348 Couldn't move '$distdir' to '$packagedir': $!
5349
5350 Cannot continue: Please find the reason why I cannot move
5351 $builddir/tmp-$$/$distdir
5352 to
5353 $packagedir
5354 and fix the problem, then retry
5355
5356 EOF
5357             }
5358             $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
5359                                  $distdir,
5360                                  $packagedir,
5361                                  -e $packagedir,
5362                                  -d $packagedir,
5363                                 )) if $CPAN::DEBUG;
5364         } else {
5365             my $userid = $self->cpan_userid;
5366             CPAN->debug("userid[$userid]");
5367             if (!$userid or $userid eq "N/A") {
5368                 $userid = "anon";
5369             }
5370             my $pragmatic_dir = $userid . '000';
5371             $pragmatic_dir =~ s/\W_//g;
5372             $pragmatic_dir++ while -d "../$pragmatic_dir";
5373             $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
5374             $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
5375             File::Path::mkpath($packagedir);
5376             my($f);
5377             for $f (@readdir) { # is already without "." and ".."
5378                 my $to = File::Spec->catdir($packagedir,$f);
5379                 File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
5380             }
5381         }
5382     }
5383     if ($CPAN::Signal){
5384         $self->safe_chdir($sub_wd);
5385         return;
5386     }
5387
5388     $self->{'build_dir'} = $packagedir;
5389     $self->safe_chdir($builddir);
5390     File::Path::rmtree("tmp-$$");
5391
5392     $self->safe_chdir($packagedir);
5393     $self->_signature_business();
5394     $self->safe_chdir($builddir);
5395     return if $CPAN::Signal;
5396
5397
5398     my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
5399     my($mpl_exists) = -f $mpl;
5400     unless ($mpl_exists) {
5401         # NFS has been reported to have racing problems after the
5402         # renaming of a directory in some environments.
5403         # This trick helps.
5404         $CPAN::Frontend->mysleep(1);
5405         my $mpldh = DirHandle->new($packagedir)
5406             or Carp::croak("Couldn't opendir $packagedir: $!");
5407         $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
5408         $mpldh->close;
5409     }
5410     my $prefer_installer = "eumm"; # eumm|mb
5411     if (-f File::Spec->catfile($packagedir,"Build.PL")) {
5412         if ($mpl_exists) { # they *can* choose
5413             $prefer_installer = CPAN::HandleConfig->prefs_lookup($self,
5414                                                                  q{prefer_installer});
5415         } else {
5416             $prefer_installer = "mb";
5417         }
5418     }
5419     return unless $self->patch;
5420     if (lc($prefer_installer) eq "mb") {
5421         $self->{modulebuild} = 1;
5422     } elsif (! $mpl_exists) {
5423         $self->_edge_cases($mpl,$packagedir,$local_file);
5424     }
5425     if ($self->{build_dir}
5426         &&
5427         $CPAN::Config->{build_dir_reuse}
5428        ) {
5429         $self->store_persistent_state;
5430     }
5431
5432     return $self;
5433 }
5434
5435 #-> CPAN::Distribution::store_persistent_state
5436 sub store_persistent_state {
5437     my($self) = @_;
5438     my $file = sprintf "%s.yml", $self->{build_dir};
5439     CPAN->_yaml_dumpfile(
5440                          $file,
5441                          {
5442                           time => time,
5443                           perl => CPAN::_perl_fingerprint,
5444                           distribution => $self,
5445                          }
5446                         );
5447 }
5448
5449 #-> CPAN::Distribution::patch
5450 sub try_download {
5451     my($self,$patch) = @_;
5452     my $norm = $self->normalize($patch);
5453     my($local_wanted) =
5454         File::Spec->catfile(
5455                             $CPAN::Config->{keep_source_where},
5456                             "authors",
5457                             "id",
5458                             split(/\//,$norm),
5459                             );
5460     $self->debug("Doing localize") if $CPAN::DEBUG;
5461     return CPAN::FTP->localize("authors/id/$norm",
5462                                $local_wanted);
5463 }
5464
5465 #-> CPAN::Distribution::patch
5466 sub patch {
5467     my($self) = @_;
5468     if (my $patches = $self->prefs->{patches}) {
5469         return unless @$patches;
5470         $self->safe_chdir($self->{build_dir});
5471         CPAN->debug("patches[$patches]");
5472         my $patchbin = $CPAN::Config->{patch};
5473         unless ($patchbin && length $patchbin) {
5474             $CPAN::Frontend->mydie("No external patch command configured\n\n".
5475                                    "Please run 'o conf init /patch/'\n\n");
5476         }
5477         unless (MM->maybe_command($patchbin)) {
5478             $CPAN::Frontend->mydie("No external patch command available\n\n".
5479                                    "Please run 'o conf init /patch/'\n\n");
5480         }
5481         $patchbin = CPAN::HandleConfig->safe_quote($patchbin);
5482         local $ENV{PATCH_GET} = 0; # shall replace -g0 which is not
5483                                    # supported everywhere (and then,
5484                                    # not ever necessary there)
5485         my $stdpatchargs = "-N --fuzz=3";
5486         my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches");
5487         $CPAN::Frontend->myprint("Going to apply $countedpatches:\n");
5488         for my $patch (@$patches) {
5489             unless (-f $patch) {
5490                 if (my $trydl = $self->try_download($patch)) {
5491                     $patch = $trydl;
5492                 } else {
5493                     my $fail = "Could not find patch '$patch'";
5494                     $CPAN::Frontend->mywarn("$fail; cannot continue\n");
5495                     $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
5496                     delete $self->{build_dir};
5497                     return;
5498                 }
5499             }
5500             $CPAN::Frontend->myprint("  $patch\n");
5501             my $readfh = CPAN::Tarzip->TIEHANDLE($patch);
5502             my $thispatchargs = join " ", $stdpatchargs, $self->_patch_p_parameter($readfh);
5503             $readfh = CPAN::Tarzip->TIEHANDLE($patch);
5504             my $writefh = FileHandle->new;
5505             unless (open $writefh, "|$patchbin $thispatchargs") {
5506                 my $fail = "Could not fork '$patchbin $thispatchargs'";
5507                 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
5508                 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
5509                 delete $self->{build_dir};
5510                 return;
5511             }
5512             while (my $x = $readfh->READLINE) {
5513                 print $writefh $x;
5514             }
5515             unless (close $writefh) {
5516                 my $fail = "Could not apply patch '$patch'";
5517                 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
5518                 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
5519                 delete $self->{build_dir};
5520                 return;
5521             }
5522         }
5523         $self->{patched}++;
5524     }
5525     return 1;
5526 }
5527
5528 sub _patch_p_parameter {
5529     my($self,$fh) = @_;
5530     my($cnt_files,$cnt_p0files);
5531     local($_);
5532     while ($_ = $fh->READLINE) {
5533         next unless /^[\*\+]{3}\s(\S+)/;
5534         my $file = $1;
5535         $cnt_files++;
5536         $cnt_p0files++ if -f $file;
5537     }
5538     return $cnt_files==$cnt_p0files ? "-p0" : "-p1";
5539 }
5540
5541 #-> sub CPAN::Distribution::_edge_cases
5542 # with "configure" or "Makefile" or single file scripts
5543 sub _edge_cases {
5544     my($self,$mpl,$packagedir,$local_file) = @_;
5545     $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
5546                          $mpl,
5547                          CPAN::anycwd(),
5548                         )) if $CPAN::DEBUG;
5549     my($configure) = File::Spec->catfile($packagedir,"Configure");
5550     if (-f $configure) {
5551         # do we have anything to do?
5552         $self->{configure} = $configure;
5553     } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
5554         $CPAN::Frontend->mywarn(qq{
5555 Package comes with a Makefile and without a Makefile.PL.
5556 We\'ll try to build it with that Makefile then.
5557 });
5558         $self->{writemakefile} = CPAN::Distrostatus->new("YES");
5559         $CPAN::Frontend->mysleep(2);
5560     } else {
5561         my $cf = $self->called_for || "unknown";
5562         if ($cf =~ m|/|) {
5563             $cf =~ s|.*/||;
5564             $cf =~ s|\W.*||;
5565         }
5566         $cf =~ s|[/\\:]||g;     # risk of filesystem damage
5567         $cf = "unknown" unless length($cf);
5568         $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
5569   (The test -f "$mpl" returned false.)
5570   Writing one on our own (setting NAME to $cf)\a\n});
5571         $self->{had_no_makefile_pl}++;
5572         $CPAN::Frontend->mysleep(3);
5573
5574         # Writing our own Makefile.PL
5575
5576         my $script = "";
5577         if ($self->{archived} eq "maybe_pl") {
5578             my $fh = FileHandle->new;
5579             my $script_file = File::Spec->catfile($packagedir,$local_file);
5580             $fh->open($script_file)
5581                 or Carp::croak("Could not open $script_file: $!");
5582             local $/ = "\n";
5583             # name parsen und prereq
5584             my($state) = "poddir";
5585             my($name, $prereq) = ("", "");
5586             while (<$fh>) {
5587                 if ($state eq "poddir" && /^=head\d\s+(\S+)/) {
5588                     if ($1 eq 'NAME') {
5589                         $state = "name";
5590                     } elsif ($1 eq 'PREREQUISITES') {
5591                         $state = "prereq";
5592                     }
5593                 } elsif ($state =~ m{^(name|prereq)$}) {
5594                     if (/^=/) {
5595                         $state = "poddir";
5596                     } elsif (/^\s*$/) {
5597                         # nop
5598                     } elsif ($state eq "name") {
5599                         if ($name eq "") {
5600                             ($name) = /^(\S+)/;
5601                             $state = "poddir";
5602                         }
5603                     } elsif ($state eq "prereq") {
5604                         $prereq .= $_;
5605                     }
5606                 } elsif (/^=cut\b/) {
5607                     last;
5608                 }
5609             }
5610             $fh->close;
5611
5612             for ($name) {
5613                 s{.*<}{};       # strip X<...>
5614                 s{>.*}{};
5615             }
5616             chomp $prereq;
5617             $prereq = join " ", split /\s+/, $prereq;
5618             my($PREREQ_PM) = join("\n", map {
5619                 s{.*<}{};       # strip X<...>
5620                 s{>.*}{};
5621                 if (/[\s\'\"]/) { # prose?
5622                 } else {
5623                     s/[^\w:]$//; # period?
5624                     " "x28 . "'$_' => 0,";
5625                 }
5626             } split /\s*,\s*/, $prereq);
5627
5628             $script = "
5629               EXE_FILES => ['$name'],
5630               PREREQ_PM => {
5631 $PREREQ_PM
5632                            },
5633 ";
5634             if ($name) {
5635                 my $to_file = File::Spec->catfile($packagedir, $name);
5636                 rename $script_file, $to_file
5637                     or die "Can't rename $script_file to $to_file: $!";
5638             }
5639         }
5640
5641         my $fh = FileHandle->new;
5642         $fh->open(">$mpl")
5643             or Carp::croak("Could not open >$mpl: $!");
5644         $fh->print(
5645                    qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
5646 # because there was no Makefile.PL supplied.
5647 # Autogenerated on: }.scalar localtime().qq{
5648
5649 use ExtUtils::MakeMaker;
5650 WriteMakefile(
5651               NAME => q[$cf],$script
5652              );
5653 });
5654         $fh->close;
5655     }
5656 }
5657
5658 #-> CPAN::Distribution::_signature_business
5659 sub _signature_business {
5660     my($self) = @_;
5661     if ($CPAN::Config->{check_sigs}) {
5662         if ($CPAN::META->has_inst("Module::Signature")) {
5663             if (-f "SIGNATURE") {
5664                 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
5665                 my $rv = Module::Signature::verify();
5666                 if ($rv != Module::Signature::SIGNATURE_OK() and
5667                     $rv != Module::Signature::SIGNATURE_MISSING()) {
5668                     $CPAN::Frontend->mywarn(
5669                                             qq{\nSignature invalid for }.
5670                                             qq{distribution file. }.
5671                                             qq{Please investigate.\n\n}
5672                                            );
5673
5674                     my $wrap =
5675                         sprintf(qq{I'd recommend removing %s. Its signature
5676 is invalid. Maybe you have configured your 'urllist' with
5677 a bad URL. Please check this array with 'o conf urllist', and
5678 retry. For more information, try opening a subshell with
5679   look %s
5680 and there run
5681   cpansign -v
5682 },
5683                                 $self->{localfile},
5684                                 $self->pretty_id,
5685                                );
5686                     $self->{signature_verify} = CPAN::Distrostatus->new("NO");
5687                     $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
5688                     $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
5689                 } else {
5690                     $self->{signature_verify} = CPAN::Distrostatus->new("YES");
5691                     $self->debug("Module::Signature has verified") if $CPAN::DEBUG;
5692                 }
5693             } else {
5694                 $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n});
5695             }
5696         } else {
5697             $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
5698         }
5699     }
5700 }
5701
5702 #-> CPAN::Distribution::untar_me ;
5703 sub untar_me {
5704     my($self,$ct) = @_;
5705     $self->{archived} = "tar";
5706     if ($ct->untar()) {
5707         $self->{unwrapped} = CPAN::Distrostatus->new("YES");
5708     } else {
5709         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed");
5710     }
5711 }
5712
5713 # CPAN::Distribution::unzip_me ;
5714 sub unzip_me {
5715     my($self,$ct) = @_;
5716     $self->{archived} = "zip";
5717     if ($ct->unzip()) {
5718         $self->{unwrapped} = CPAN::Distrostatus->new("YES");
5719     } else {
5720         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed");
5721     }
5722     return;
5723 }
5724
5725 sub handle_singlefile {
5726     my($self,$local_file) = @_;
5727
5728     if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ){
5729         $self->{archived} = "pm";
5730     } else {
5731         $self->{archived} = "maybe_pl";
5732     }
5733
5734     my $to = File::Basename::basename($local_file);
5735     if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
5736         if (CPAN::Tarzip->new($local_file)->gunzip($to)) {
5737             $self->{unwrapped} = CPAN::Distrostatus->new("YES");
5738         } else {
5739             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- uncompressing failed");
5740         }
5741     } else {
5742         File::Copy::cp($local_file,".");
5743         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed");
5744     }
5745     return $to;
5746 }
5747
5748 #-> sub CPAN::Distribution::new ;
5749 sub new {
5750     my($class,%att) = @_;
5751
5752     # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
5753
5754     my $this = { %att };
5755     return bless $this, $class;
5756 }
5757
5758 #-> sub CPAN::Distribution::look ;
5759 sub look {
5760     my($self) = @_;
5761
5762     if ($^O eq 'MacOS') {
5763       $self->Mac::BuildTools::look;
5764       return;
5765     }
5766
5767     if (  $CPAN::Config->{'shell'} ) {
5768         $CPAN::Frontend->myprint(qq{
5769 Trying to open a subshell in the build directory...
5770 });
5771     } else {
5772         $CPAN::Frontend->myprint(qq{
5773 Your configuration does not define a value for subshells.
5774 Please define it with "o conf shell <your shell>"
5775 });
5776         return;
5777     }
5778     my $dist = $self->id;
5779     my $dir;
5780     unless ($dir = $self->dir) {
5781         $self->get;
5782     }
5783     unless ($dir ||= $self->dir) {
5784         $CPAN::Frontend->mywarn(qq{
5785 Could not determine which directory to use for looking at $dist.
5786 });
5787         return;
5788     }
5789     my $pwd  = CPAN::anycwd();
5790     $self->safe_chdir($dir);
5791     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
5792     {
5793         local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
5794         $ENV{CPAN_SHELL_LEVEL} += 1;
5795         my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'});
5796         unless (system($shell) == 0) {
5797             my $code = $? >> 8;
5798             $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
5799         }
5800     }
5801     $self->safe_chdir($pwd);
5802 }
5803
5804 # CPAN::Distribution::cvs_import ;
5805 sub cvs_import {
5806     my($self) = @_;
5807     $self->get;
5808     my $dir = $self->dir;
5809
5810     my $package = $self->called_for;
5811     my $module = $CPAN::META->instance('CPAN::Module', $package);
5812     my $version = $module->cpan_version;
5813
5814     my $userid = $self->cpan_userid;
5815
5816     my $cvs_dir = (split /\//, $dir)[-1];
5817     $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
5818     my $cvs_root =
5819       $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
5820     my $cvs_site_perl =
5821       $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
5822     if ($cvs_site_perl) {
5823         $cvs_dir = "$cvs_site_perl/$cvs_dir";
5824     }
5825     my $cvs_log = qq{"imported $package $version sources"};
5826     $version =~ s/\./_/g;
5827     # XXX cvs: undocumented and unclear how it was meant to work
5828     my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
5829                "$cvs_dir", $userid, "v$version");
5830
5831     my $pwd  = CPAN::anycwd();
5832     chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
5833
5834     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
5835
5836     $CPAN::Frontend->myprint(qq{@cmd\n});
5837     system(@cmd) == 0 or
5838     # XXX cvs
5839         $CPAN::Frontend->mydie("cvs import failed");
5840     chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
5841 }
5842
5843 #-> sub CPAN::Distribution::readme ;
5844 sub readme {
5845     my($self) = @_;
5846     my($dist) = $self->id;
5847     my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
5848     $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
5849     my($local_file);
5850     my($local_wanted) =
5851          File::Spec->catfile(
5852                              $CPAN::Config->{keep_source_where},
5853                              "authors",
5854                              "id",
5855                              split(/\//,"$sans.readme"),
5856                             );
5857     $self->debug("Doing localize") if $CPAN::DEBUG;
5858     $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
5859                                       $local_wanted)
5860         or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
5861
5862     if ($^O eq 'MacOS') {
5863         Mac::BuildTools::launch_file($local_file);
5864         return;
5865     }
5866
5867     my $fh_pager = FileHandle->new;
5868     local($SIG{PIPE}) = "IGNORE";
5869     my $pager = $CPAN::Config->{'pager'} || "cat";
5870     $fh_pager->open("|$pager")
5871         or die "Could not open pager $pager\: $!";
5872     my $fh_readme = FileHandle->new;
5873     $fh_readme->open($local_file)
5874         or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
5875     $CPAN::Frontend->myprint(qq{
5876 Displaying file
5877   $local_file
5878 with pager "$pager"
5879 });
5880     $fh_pager->print(<$fh_readme>);
5881     $fh_pager->close;
5882 }
5883
5884 #-> sub CPAN::Distribution::verifyCHECKSUM ;
5885 sub verifyCHECKSUM {
5886     my($self) = @_;
5887   EXCUSE: {
5888         my @e;
5889         $self->{CHECKSUM_STATUS} ||= "";
5890         $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
5891         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
5892     }
5893     my($lc_want,$lc_file,@local,$basename);
5894     @local = split(/\//,$self->id);
5895     pop @local;
5896     push @local, "CHECKSUMS";
5897     $lc_want =
5898         File::Spec->catfile($CPAN::Config->{keep_source_where},
5899                             "authors", "id", @local);
5900     local($") = "/";
5901     if (my $size = -s $lc_want) {
5902         $self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG;
5903         if ($self->CHECKSUM_check_file($lc_want,1)) {
5904             return $self->{CHECKSUM_STATUS} = "OK";
5905         }
5906     }
5907     $lc_file = CPAN::FTP->localize("authors/id/@local",
5908                                    $lc_want,1);
5909     unless ($lc_file) {
5910         $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
5911         $local[-1] .= ".gz";
5912         $lc_file = CPAN::FTP->localize("authors/id/@local",
5913                                        "$lc_want.gz",1);
5914         if ($lc_file) {
5915             $lc_file =~ s/\.gz(?!\n)\Z//;
5916             CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file);
5917         } else {
5918             return;
5919         }
5920     }
5921     if ($self->CHECKSUM_check_file($lc_file)) {
5922         return $self->{CHECKSUM_STATUS} = "OK";
5923     }
5924 }
5925
5926 #-> sub CPAN::Distribution::SIG_check_file ;
5927 sub SIG_check_file {
5928     my($self,$chk_file) = @_;
5929     my $rv = eval { Module::Signature::_verify($chk_file) };
5930
5931     if ($rv == Module::Signature::SIGNATURE_OK()) {
5932         $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
5933         return $self->{SIG_STATUS} = "OK";
5934     } else {
5935         $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
5936                                  qq{distribution file. }.
5937                                  qq{Please investigate.\n\n}.
5938                                  $self->as_string,
5939                                 $CPAN::META->instance(
5940                                                         'CPAN::Author',
5941                                                         $self->cpan_userid
5942                                                         )->as_string);
5943
5944         my $wrap = qq{I\'d recommend removing $chk_file. Its signature
5945 is invalid. Maybe you have configured your 'urllist' with
5946 a bad URL. Please check this array with 'o conf urllist', and
5947 retry.};
5948
5949         $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
5950     }
5951 }
5952
5953 #-> sub CPAN::Distribution::CHECKSUM_check_file ;
5954
5955 # sloppy is 1 when we have an old checksums file that maybe is good
5956 # enough
5957
5958 sub CHECKSUM_check_file {
5959     my($self,$chk_file,$sloppy) = @_;
5960     my($cksum,$file,$basename);
5961
5962     $sloppy ||= 0;
5963     $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG;
5964     if ($CPAN::Config->{check_sigs}) {
5965         if ($CPAN::META->has_inst("Module::Signature")) {
5966             $self->debug("Module::Signature is installed, verifying");
5967             $self->SIG_check_file($chk_file);
5968         } else {
5969             $self->debug("Module::Signature is NOT installed");
5970         }
5971     }
5972
5973     $file = $self->{localfile};
5974     $basename = File::Basename::basename($file);
5975     my $fh = FileHandle->new;
5976     if (open $fh, $chk_file){
5977         local($/);
5978         my $eval = <$fh>;
5979         $eval =~ s/\015?\012/\n/g;
5980         close $fh;
5981         my($comp) = Safe->new();
5982         $cksum = $comp->reval($eval);
5983         if ($@) {
5984             rename $chk_file, "$chk_file.bad";
5985             Carp::confess($@) if $@;
5986         }
5987     } else {
5988         Carp::carp "Could not open $chk_file for reading";
5989     }
5990
5991     if (! ref $cksum or ref $cksum ne "HASH") {
5992         $CPAN::Frontend->mywarn(qq{
5993 Warning: checksum file '$chk_file' broken.
5994
5995 When trying to read that file I expected to get a hash reference
5996 for further processing, but got garbage instead.
5997 });
5998         my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
5999         $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
6000         $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken";
6001         return;
6002     } elsif (exists $cksum->{$basename}{sha256}) {
6003         $self->debug("Found checksum for $basename:" .
6004                      "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
6005
6006         open($fh, $file);
6007         binmode $fh;
6008         my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
6009         $fh->close;
6010         $fh = CPAN::Tarzip->TIEHANDLE($file);
6011
6012         unless ($eq) {
6013           my $dg = Digest::SHA->new(256);
6014           my($data,$ref);
6015           $ref = \$data;
6016           while ($fh->READ($ref, 4096) > 0){
6017             $dg->add($data);
6018           }
6019           my $hexdigest = $dg->hexdigest;
6020           $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
6021         }
6022
6023         if ($eq) {
6024           $CPAN::Frontend->myprint("Checksum for $file ok\n");
6025           return $self->{CHECKSUM_STATUS} = "OK";
6026         } else {
6027             $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
6028                                      qq{distribution file. }.
6029                                      qq{Please investigate.\n\n}.
6030                                      $self->as_string,
6031                                      $CPAN::META->instance(
6032                                                            'CPAN::Author',
6033                                                            $self->cpan_userid
6034                                                           )->as_string);
6035
6036             my $wrap = qq{I\'d recommend removing $file. Its
6037 checksum is incorrect. Maybe you have configured your 'urllist' with
6038 a bad URL. Please check this array with 'o conf urllist', and
6039 retry.};
6040
6041             $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
6042
6043             # former versions just returned here but this seems a
6044             # serious threat that deserves a die
6045
6046             # $CPAN::Frontend->myprint("\n\n");
6047             # sleep 3;
6048             # return;
6049         }
6050         # close $fh if fileno($fh);
6051     } else {
6052         return if $sloppy;
6053         unless ($self->{CHECKSUM_STATUS}) {
6054             $CPAN::Frontend->mywarn(qq{
6055 Warning: No checksum for $basename in $chk_file.
6056
6057 The cause for this may be that the file is very new and the checksum
6058 has not yet been calculated, but it may also be that something is
6059 going awry right now.
6060 });
6061             my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes");
6062             $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
6063         }
6064         $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file";
6065         return;
6066     }
6067 }
6068
6069 #-> sub CPAN::Distribution::eq_CHECKSUM ;
6070 sub eq_CHECKSUM {
6071     my($self,$fh,$expect) = @_;
6072     if ($CPAN::META->has_inst("Digest::SHA")) {
6073         my $dg = Digest::SHA->new(256);
6074         my($data);
6075         while (read($fh, $data, 4096)){
6076             $dg->add($data);
6077         }
6078         my $hexdigest = $dg->hexdigest;
6079         # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
6080         return $hexdigest eq $expect;
6081     }
6082     return 1;
6083 }
6084
6085 #-> sub CPAN::Distribution::force ;
6086
6087 # Both CPAN::Modules and CPAN::Distributions know if "force" is in
6088 # effect by autoinspection, not by inspecting a global variable. One
6089 # of the reason why this was chosen to work that way was the treatment
6090 # of dependencies. They should not automatically inherit the force
6091 # status. But this has the downside that ^C and die() will return to
6092 # the prompt but will not be able to reset the force_update
6093 # attributes. We try to correct for it currently in the read_metadata
6094 # routine, and immediately before we check for a Signal. I hope this
6095 # works out in one of v1.57_53ff
6096
6097 # "Force get forgets previous error conditions"
6098
6099 #-> sub CPAN::Distribution::force ;
6100 sub force {
6101   my($self, $method) = @_;
6102   for my $att (qw(
6103                   CHECKSUM_STATUS
6104                   archived
6105                   badtestcnt
6106                   build_dir
6107                   install
6108                   localfile
6109                   make
6110                   make_test
6111                   modulebuild
6112                   prefs
6113                   prefs_file
6114                   prereq_pm
6115                   prereq_pm_detected
6116                   reqtype
6117                   signature_verify
6118                   unwrapped
6119                   writemakefile
6120                   yaml_content
6121  )) {
6122     delete $self->{$att};
6123     CPAN->debug(sprintf "att[%s]", $att) if $CPAN::DEBUG;
6124   }
6125   if ($method && $method =~ /make|test|install/) {
6126     $self->{"force_update"}++; # name should probably have been force_install
6127   }
6128 }
6129
6130 #-> sub CPAN::Distribution::notest ;
6131 sub notest {
6132   my($self, $method) = @_;
6133   # warn "XDEBUG: set notest for $self $method";
6134   $self->{"notest"}++; # name should probably have been force_install
6135 }
6136
6137 #-> sub CPAN::Distribution::unnotest ;
6138 sub unnotest {
6139   my($self) = @_;
6140   # warn "XDEBUG: deleting notest";
6141   delete $self->{'notest'};
6142 }
6143
6144 #-> sub CPAN::Distribution::unforce ;
6145 sub unforce {
6146   my($self) = @_;
6147   delete $self->{'force_update'};
6148 }
6149
6150 #-> sub CPAN::Distribution::isa_perl ;
6151 sub isa_perl {
6152   my($self) = @_;
6153   my $file = File::Basename::basename($self->id);
6154   if ($file =~ m{ ^ perl
6155                   -?
6156                   (5)
6157                   ([._-])
6158                   (
6159                    \d{3}(_[0-4][0-9])?
6160                    |
6161                    \d+\.\d+
6162                   )
6163                   \.tar[._-](?:gz|bz2)
6164                   (?!\n)\Z
6165                 }xs){
6166     return "$1.$3";
6167   } elsif ($self->cpan_comment
6168            &&
6169            $self->cpan_comment =~ /isa_perl\(.+?\)/){
6170     return $1;
6171   }
6172 }
6173
6174
6175 #-> sub CPAN::Distribution::perl ;
6176 sub perl {
6177     my ($self) = @_;
6178     if (! $self) {
6179         use Carp qw(carp);
6180         carp __PACKAGE__ . "::perl was called without parameters.";
6181     }
6182     return CPAN::HandleConfig->safe_quote($CPAN::Perl);
6183 }
6184
6185
6186 #-> sub CPAN::Distribution::make ;
6187 sub make {
6188     my($self) = @_;
6189     my $make = $self->{modulebuild} ? "Build" : "make";
6190     # Emergency brake if they said install Pippi and get newest perl
6191     if ($self->isa_perl) {
6192       if (
6193           $self->called_for ne $self->id &&
6194           ! $self->{force_update}
6195          ) {
6196         # if we die here, we break bundles
6197         $CPAN::Frontend
6198             ->mywarn(sprintf(
6199                              qq{The most recent version "%s" of the module "%s"
6200 is part of the perl-%s distribution. To install that, you need to run
6201   force install %s   --or--
6202   install %s
6203 },
6204                              $CPAN::META->instance(
6205                                                    'CPAN::Module',
6206                                                    $self->called_for
6207                                                   )->cpan_version,
6208                              $self->called_for,
6209                              $self->isa_perl,
6210                              $self->called_for,
6211                              $self->id,
6212                             ));
6213         $self->{make} = CPAN::Distrostatus->new("NO isa perl");
6214         $CPAN::Frontend->mysleep(1);
6215         return;
6216       }
6217     }
6218     $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
6219     $self->get;
6220     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
6221                            ? $ENV{PERL5LIB}
6222                            : ($ENV{PERLLIB} || "");
6223
6224     $CPAN::META->set_perl5lib;
6225     local $ENV{MAKEFLAGS}; # protect us from outer make calls
6226
6227     if ($CPAN::Signal){
6228       delete $self->{force_update};
6229       return;
6230     }
6231   EXCUSE: {
6232         my @e;
6233         if (!$self->{archived} || $self->{archived} eq "NO") {
6234             push @e, "Is neither a tar nor a zip archive.";
6235         }
6236
6237         if (!$self->{unwrapped}
6238             || (
6239                 $self->{unwrapped}->can("failed") ?
6240                 $self->{unwrapped}->failed :
6241                 $self->{unwrapped} =~ /^NO/
6242                )) {
6243             push @e, "Had problems unarchiving. Please build manually";
6244         }
6245
6246         unless ($self->{force_update}) {
6247             exists $self->{signature_verify} and (
6248                          $self->{signature_verify}->can("failed") ?
6249                          $self->{signature_verify}->failed :
6250                          $self->{signature_verify} =~ /^NO/
6251                         )
6252                 and push @e, "Did not pass the signature test.";
6253         }
6254
6255         if (exists $self->{writemakefile} &&
6256             (
6257              $self->{writemakefile}->can("failed") ?
6258              $self->{writemakefile}->failed :
6259              $self->{writemakefile} =~ /^NO/
6260             )) {
6261             # XXX maybe a retry would be in order?
6262             my $err = $self->{writemakefile}->can("text") ?
6263                 $self->{writemakefile}->text :
6264                     $self->{writemakefile};
6265             $err =~ s/^NO\s*//;
6266             $err ||= "Had some problem writing Makefile";
6267             $err .= ", won't make";
6268             push @e, $err;
6269         }
6270
6271         defined $self->{make} and push @e,
6272             "Has already been processed within this session";
6273
6274         if (exists $self->{later} and length($self->{later})) {
6275             if ($self->unsat_prereq) {
6276                 push @e, $self->{later};
6277 # RT ticket 18438 raises doubts if the deletion of {later} is valid.
6278 # YAML-0.53 triggered the later hodge-podge here, but my margin notes
6279 # are not sufficient to be sure if we really must/may do the delete
6280 # here. SO I accept the suggested patch for now. If we trigger a bug
6281 # again, I must go into deep contemplation about the {later} flag.
6282
6283 #            } else {
6284 #                delete $self->{later};
6285             }
6286         }
6287
6288         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
6289     }
6290     if ($CPAN::Signal){
6291       delete $self->{force_update};
6292       return;
6293     }
6294     $CPAN::Frontend->myprint("\n  CPAN.pm: Going to build ".$self->id."\n\n");
6295     my $builddir = $self->dir or
6296         $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
6297     chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
6298     $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
6299
6300     if ($^O eq 'MacOS') {
6301         Mac::BuildTools::make($self);
6302         return;
6303     }
6304
6305     my $system;
6306     if ($self->{'configure'}) {
6307         $system = $self->{'configure'};
6308     } elsif ($self->{modulebuild}) {
6309         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
6310         $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}";
6311     } else {
6312         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
6313         my $switch = "";
6314 # This needs a handler that can be turned on or off:
6315 #       $switch = "-MExtUtils::MakeMaker ".
6316 #           "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
6317 #           if $] > 5.00310;
6318         my $makepl_arg = $self->make_x_arg("pl");
6319         $system = sprintf("%s%s Makefile.PL%s",
6320                           $perl,
6321                           $switch ? " $switch" : "",
6322                           $makepl_arg ? " $makepl_arg" : "",
6323                          );
6324     }
6325     my %env;
6326     while (my($k,$v) = each %ENV) {
6327         next unless defined $v;
6328         $env{$k} = $v;
6329     }
6330     local %ENV = %env;
6331     if (my $env = $self->prefs->{pl}{env}) {
6332         for my $e (keys %$env) {
6333             $ENV{$e} = $env->{$e};
6334         }
6335     }
6336     if (exists $self->{writemakefile}) {
6337     } else {
6338         local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
6339         my($ret,$pid);
6340         $@ = "";
6341         my $go_via_alarm;
6342         if ($CPAN::Config->{inactivity_timeout}) {
6343             require Config;
6344             if ($Config::Config{d_alarm}
6345                 &&
6346                 $Config::Config{d_alarm} eq "define"
6347                ) {
6348                 $go_via_alarm++
6349             } else {
6350                 $CPAN::Frontend->mywarn("Warning: you have configured the config ".
6351                                         "variable 'inactivity_timeout' to ".
6352                                         "'$CPAN::Config->{inactivity_timeout}'. But ".
6353                                         "on this machine the system call 'alarm' ".
6354                                         "isn't available. This means that we cannot ".
6355                                         "provide the feature of intercepting long ".
6356                                         "waiting code and will turn this feature off.\n"
6357                                        );
6358                 $CPAN::Config->{inactivity_timeout} = 0;
6359             }
6360         }
6361         if ($go_via_alarm) {
6362             eval {
6363                 alarm $CPAN::Config->{inactivity_timeout};
6364                 local $SIG{CHLD}; # = sub { wait };
6365                 if (defined($pid = fork)) {
6366                     if ($pid) { #parent
6367                         # wait;
6368                         waitpid $pid, 0;
6369                     } else {    #child
6370                         # note, this exec isn't necessary if
6371                         # inactivity_timeout is 0. On the Mac I'd
6372                         # suggest, we set it always to 0.
6373                         exec $system;
6374                     }
6375                 } else {
6376                     $CPAN::Frontend->myprint("Cannot fork: $!");
6377                     return;
6378                 }
6379             };
6380             alarm 0;
6381             if ($@){
6382                 kill 9, $pid;
6383                 waitpid $pid, 0;
6384                 my $err = "$@";
6385                 $CPAN::Frontend->myprint($err);
6386                 $self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
6387                 $@ = "";
6388                 return;
6389             }
6390         } else {
6391             if (my $expect_model = $self->_prefs_with_expect("pl")) {
6392                 $ret = $self->_run_via_expect($system,$expect_model);
6393                 if (! defined $ret
6394                     && $self->{writemakefile}
6395                     && $self->{writemakefile}->failed) {
6396                     # timeout
6397                     return;
6398                 }
6399             } else {
6400                 $ret = system($system);
6401             }
6402             if ($ret != 0) {
6403                 $self->{writemakefile} = CPAN::Distrostatus
6404                     ->new("NO '$system' returned status $ret");
6405                 $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
6406                 $self->store_persistent_state;
6407                 $self->store_persistent_state;
6408                 return;
6409             }
6410         }
6411         if (-f "Makefile" || -f "Build") {
6412           $self->{writemakefile} = CPAN::Distrostatus->new("YES");
6413           delete $self->{make_clean}; # if cleaned before, enable next
6414         } else {
6415           $self->{writemakefile} = CPAN::Distrostatus
6416               ->new(qq{NO -- Unknown reason});
6417         }
6418     }
6419     if ($CPAN::Signal){
6420       delete $self->{force_update};
6421       return;
6422     }
6423     if (my @prereq = $self->unsat_prereq){
6424         if ($prereq[0][0] eq "perl") {
6425             my $need = "requires perl '$prereq[0][1]'";
6426             my $id = $self->pretty_id;
6427             $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
6428             $self->{make} = CPAN::Distrostatus->new("NO $need");
6429             $self->store_persistent_state;
6430             return;
6431         } else {
6432             return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
6433         }
6434     }
6435     if ($CPAN::Signal){
6436       delete $self->{force_update};
6437       return;
6438     }
6439     if ($self->{modulebuild}) {
6440         unless (-f "Build") {
6441             my $cwd = Cwd::cwd;
6442             $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
6443                                     " in cwd[$cwd]. Danger, Will Robinson!");
6444             $CPAN::Frontend->mysleep(5);
6445         }
6446         $system = sprintf "%s %s", $self->_build_command(), $CPAN::Config->{mbuild_arg};
6447     } else {
6448         $system = join " ", $self->_make_command(), $CPAN::Config->{make_arg};
6449     }
6450     my $make_arg = $self->make_x_arg("make");
6451     $system = sprintf("%s%s",
6452                       $system,
6453                       $make_arg ? " $make_arg" : "",
6454                      );
6455     if (my $env = $self->prefs->{make}{env}) { # overriding the local
6456                                                # ENV of PL, not the
6457                                                # outer ENV, but
6458                                                # unlikely to be a risk
6459         for my $e (keys %$env) {
6460             $ENV{$e} = $env->{$e};
6461         }
6462     }
6463     my $expect_model = $self->_prefs_with_expect("make");
6464     my $want_expect = 0;
6465     if ( $expect_model && @{$expect_model->{talk}} ) {
6466         my $can_expect = $CPAN::META->has_inst("Expect");
6467         if ($can_expect) {
6468             $want_expect = 1;
6469         } else {
6470             $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
6471                                     "system\n");
6472         }
6473     }
6474     my $system_ok;
6475     if ($want_expect) {
6476         $system_ok = $self->_run_via_expect($system,$expect_model) == 0;
6477     } else {
6478         $system_ok = system($system) == 0;
6479     }
6480     $self->introduce_myself;
6481     if ( $system_ok ) {
6482          $CPAN::Frontend->myprint("  $system -- OK\n");
6483          $self->{make} = CPAN::Distrostatus->new("YES");
6484     } else {
6485          $self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
6486          $self->{make} = CPAN::Distrostatus->new("NO");
6487          $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
6488     }
6489     $self->store_persistent_state;
6490 }
6491
6492 # CPAN::Distribution::_run_via_expect
6493 sub _run_via_expect {
6494     my($self,$system,$expect_model) = @_;
6495     CPAN->debug("system[$system]expect_model[$expect_model]") if $CPAN::DEBUG;
6496     if ($CPAN::META->has_inst("Expect")) {
6497         my $expo = Expect->new;  # expo Expect object;
6498         $expo->spawn($system);
6499         my $expecta = $expect_model->{talk};
6500         if ($expect_model->{mode} eq "expect") {
6501             return $self->_run_via_expect_deterministic($expo,$expecta);
6502         } elsif ($expect_model->{mode} eq "expect-in-any-order") {
6503             return $self->_run_via_expect_anyorder($expo,$expecta);
6504         } else {
6505             die "Panic: Illegal expect mode: $expect_model->{mode}";
6506         }
6507     } else {
6508         $CPAN::Frontend->mywarn("Expect not installed, falling back to system()\n");
6509         return system($system);
6510     }
6511 }
6512
6513 sub _run_via_expect_anyorder {
6514     my($self,$expo,$expecta) = @_;
6515     my $timeout = 3; # currently unsettable
6516     my @expectacopy = @$expecta; # we trash it!
6517     my $but = "";
6518   EXPECT: while () {
6519         my($eof,$ran_into_timeout);
6520         my @match = $expo->expect($timeout,
6521                                   [ eof => sub {
6522                                         $eof++;
6523                                     } ],
6524                                   [ timeout => sub {
6525                                         $ran_into_timeout++;
6526                                     } ],
6527                                   -re => eval"qr{.}",
6528                                  );
6529         if ($match[2]) {
6530             $but .= $match[2];
6531         }
6532         $but .= $expo->clear_accum;
6533         if ($eof) {
6534             $expo->soft_close;
6535             return $expo->exitstatus();
6536         } elsif ($ran_into_timeout) {
6537             # warn "DEBUG: they are asking a question, but[$but]";
6538             for (my $i = 0; $i <= $#expectacopy; $i+=2) {
6539                 my($next,$send) = @expectacopy[$i,$i+1];
6540                 my $regex = eval "qr{$next}";
6541                 # warn "DEBUG: will compare with regex[$regex].";
6542                 if ($but =~ /$regex/) {
6543                     # warn "DEBUG: will send send[$send]";
6544                     $expo->send($send);
6545                     splice @expectacopy, $i, 2; # never allow reusing an QA pair
6546                     next EXPECT;
6547                 }
6548             }
6549             my $why = "could not answer a question during the dialog";
6550             $CPAN::Frontend->mywarn("Failing: $why\n");
6551             $self->{writemakefile} =
6552                 CPAN::Distrostatus->new("NO $why");
6553             return;
6554         }
6555     }
6556 }
6557
6558 sub _run_via_expect_deterministic {
6559     my($self,$expo,$expecta) = @_;
6560     my $ran_into_timeout;
6561   EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) {
6562         my($next,$send) = @$expecta[$i,$i+1];
6563         my($timeout,$re);
6564         if (ref $next) {
6565             $timeout = $next->{timeout};
6566             $re = $next->{expect};
6567         } else {
6568             $timeout = 15;
6569             $re = $next;
6570         }
6571         CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG;
6572         my $regex = eval "qr{$re}";
6573         $expo->expect($timeout,
6574                       [ eof => sub {
6575                             my $but = $expo->clear_accum;
6576                             $CPAN::Frontend->mywarn("EOF (maybe harmless)
6577 expected[$regex]\nbut[$but]\n\n");
6578                             last EXPECT;
6579                         } ],
6580                       [ timeout => sub {
6581                             my $but = $expo->clear_accum;
6582                             $CPAN::Frontend->mywarn("TIMEOUT
6583 expected[$regex]\nbut[$but]\n\n");
6584                             $ran_into_timeout++;
6585                         } ],
6586                       -re => $regex);
6587         if ($ran_into_timeout){
6588             # note that the caller expects 0 for success
6589             $self->{writemakefile} =
6590                 CPAN::Distrostatus->new("NO timeout during expect dialog");
6591             return;
6592         }
6593         $expo->send($send);
6594     }
6595     $expo->soft_close;
6596     return $expo->exitstatus();
6597 }
6598
6599 # CPAN::Distribution::_find_prefs
6600 sub _find_prefs {
6601     my($self) = @_;
6602     my $distroid = $self->pretty_id;
6603     CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG;
6604     my $prefs_dir = $CPAN::Config->{prefs_dir};
6605     eval { File::Path::mkpath($prefs_dir); };
6606     if ($@) {
6607         $CPAN::Frontend->mydie("Cannot create directory $prefs_dir");
6608     }
6609     my $yaml_module = CPAN->_yaml_module;
6610     if ($CPAN::META->has_inst($yaml_module)) {
6611         my $dh = DirHandle->new($prefs_dir)
6612             or die Carp::croak("Couldn't open '$prefs_dir': $!");
6613       DIRENT: for (sort $dh->read) {
6614             next if $_ eq "." || $_ eq "..";
6615             next unless /\.yml$/;
6616             my $abs = File::Spec->catfile($prefs_dir, $_);
6617             if (-f $abs) {
6618                 CPAN->debug(sprintf "abs[%s]", $abs) if $CPAN::DEBUG;
6619                 my @yaml = @{CPAN->_yaml_loadfile($abs)};
6620                 # $DB::single=1;
6621               ELEMENT: for my $y (0..$#yaml) {
6622                     my $yaml = $yaml[$y];
6623                     my $match = $yaml->{match};
6624                     unless ($match) {
6625                         CPAN->debug("no 'match' in abs[$abs], skipping");
6626                         next ELEMENT;
6627                     }
6628                     my $ok = 1;
6629                     for my $sub_attribute (keys %$match) {
6630                         my $qr = eval "qr{$yaml->{match}{$sub_attribute}}";
6631                         if ($sub_attribute eq "module") {
6632                             my $okm = 0;
6633                             CPAN->debug(sprintf "abs[%s]yaml[%d]", $abs, scalar @yaml) if $CPAN::DEBUG;
6634                             my @modules = $self->containsmods;
6635                             CPAN->debug(sprintf "abs[%s]yaml[%d]modules[%s]", $abs, scalar @yaml, join(",",@modules)) if $CPAN::DEBUG;
6636                           MODULE: for my $module (@modules) {
6637                                 $okm ||= $module =~ /$qr/;
6638                                 last MODULE if $okm;
6639                             }
6640                             $ok &&= $okm;
6641                         } elsif ($sub_attribute eq "distribution") {
6642                             my $okd = $distroid =~ /$qr/;
6643                             $ok &&= $okd;
6644                         } elsif ($sub_attribute eq "perl") {
6645                             my $okp = $^X =~ /$qr/;
6646                             $ok &&= $okp;
6647                         } else {
6648                             $CPAN::Frontend->mydie("Nonconforming YAML file '$abs': ".
6649                                                    "unknown sub_attribut '$sub_attribute'. ".
6650                                                    "Please ".
6651                                                    "remove, cannot continue.");
6652                         }
6653                     }
6654                     CPAN->debug(sprintf "abs[%s]yaml[%d]ok[%d]", $abs, scalar @yaml, $ok) if $CPAN::DEBUG;
6655                     if ($ok) {
6656                         return {
6657                                 prefs => $yaml,
6658                                 prefs_file => $abs,
6659                                 prefs_file_doc => $y,
6660                                };
6661                     }
6662
6663                 }
6664             }
6665         }
6666     } else {
6667         unless ($self->{have_complained_about_missing_yaml}++) {
6668             $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot read prefs '$prefs_dir'\n");
6669         }
6670     }
6671     return;
6672 }
6673
6674 # CPAN::Distribution::prefs
6675 sub prefs {
6676     my($self) = @_;
6677     if (exists $self->{prefs}) {
6678         return $self->{prefs}; # XXX comment out during debugging
6679     }
6680     if ($CPAN::Config->{prefs_dir}) {
6681         CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG;
6682         my $prefs = $self->_find_prefs();
6683         if ($prefs) {
6684             for my $x (qw(prefs prefs_file prefs_file_doc)) {
6685                 $self->{$x} = $prefs->{$x};
6686             }
6687             my $bs = sprintf(
6688                              "%s[%s]",
6689                              File::Basename::basename($self->{prefs_file}),
6690                              $self->{prefs_file_doc},
6691                             );
6692             my $filler1 = "_" x 22;
6693             my $filler2 = int(66 - length($bs))/2;
6694             $filler2 = 0 if $filler2 < 0;
6695             $filler2 = " " x $filler2;
6696             $CPAN::Frontend->myprint("
6697 $filler1 D i s t r o P r e f s $filler1
6698 $filler2 $bs $filler2
6699 ");
6700             $CPAN::Frontend->mysleep(1);
6701             return $self->{prefs};
6702         }
6703     }
6704     return +{};
6705 }
6706
6707 # CPAN::Distribution::make_x_arg
6708 sub make_x_arg {
6709     my($self, $whixh) = @_;
6710     my $make_x_arg;
6711     my $prefs = $self->prefs;
6712     if (
6713         $prefs
6714         && exists $prefs->{$whixh}
6715         && exists $prefs->{$whixh}{args}
6716         && $prefs->{$whixh}{args}
6717        ) {
6718         $make_x_arg = join(" ",
6719                            map {CPAN::HandleConfig
6720                                  ->safe_quote($_)} @{$prefs->{$whixh}{args}},
6721                           );
6722     }
6723     my $what = sprintf "make%s_arg", $whixh eq "make" ? "" : $whixh;
6724     $make_x_arg ||= $CPAN::Config->{$what};
6725     return $make_x_arg;
6726 }
6727
6728 # CPAN::Distribution::_make_command
6729 sub _make_command {
6730     my ($self) = @_;
6731     if ($self) {
6732         return
6733             CPAN::HandleConfig
6734                 ->safe_quote(
6735                              CPAN::HandleConfig->prefs_lookup($self,
6736                                                               q{make})
6737                              || $Config::Config{make}
6738                              || 'make'
6739                             );
6740     } else {
6741         # Old style call, without object. Deprecated
6742         Carp::confess("CPAN::_make_command() used as function. Don't Do That.");
6743         return
6744           safe_quote(undef,
6745                      CPAN::HandleConfig->prefs_lookup($self,q{make})
6746                      || $CPAN::Config->{make}
6747                      || $Config::Config{make}
6748                      || 'make');
6749     }
6750 }
6751
6752 #-> sub CPAN::Distribution::follow_prereqs ;
6753 sub follow_prereqs {
6754     my($self) = shift;
6755     my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
6756     return unless @prereq_tuples;
6757     my @prereq = map { $_->[0] } @prereq_tuples;
6758     my $pretty_id = $self->pretty_id;
6759     my %map = (
6760                b => "build_requires",
6761                r => "requires",
6762                c => "commandline",
6763               );
6764     my($filler1,$filler2,$filler3,$filler4);
6765     my $unsat = "Unsatisfied dependencies detected during";
6766     my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id);
6767     {
6768         my $r = int(($w - length($unsat))/2);
6769         my $l = $w - length($unsat) - $r;
6770         $filler1 = "-"x4 . " "x$l;
6771         $filler2 = " "x$r . "-"x4 . "\n";
6772     }
6773     {
6774         my $r = int(($w - length($pretty_id))/2);
6775         my $l = $w - length($pretty_id) - $r;
6776         $filler3 = "-"x4 . " "x$l;
6777         $filler4 = " "x$r . "-"x4 . "\n";
6778     }
6779     $CPAN::Frontend->
6780         myprint("$filler1 $unsat $filler2".
6781                 "$filler3 $pretty_id $filler4".
6782                 join("", map {"    $_->[0] \[$map{$_->[1]}]\n"} @prereq_tuples),
6783                );
6784     my $follow = 0;
6785     if ($CPAN::Config->{prerequisites_policy} eq "follow") {
6786         $follow = 1;
6787     } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
6788         my $answer = CPAN::Shell::colorable_makemaker_prompt(
6789 "Shall I follow them and prepend them to the queue
6790 of modules we are processing right now?", "yes");
6791         $follow = $answer =~ /^\s*y/i;
6792     } else {
6793         local($") = ", ";
6794         $CPAN::Frontend->
6795             myprint("  Ignoring dependencies on modules @prereq\n");
6796     }
6797     if ($follow) {
6798         my $id = $self->id;
6799         # color them as dirty
6800         for my $p (@prereq) {
6801             # warn "calling color_cmd_tmps(0,1)";
6802             CPAN::Shell->expandany($p)->color_cmd_tmps(0,1);
6803         }
6804         # queue them and re-queue yourself
6805         CPAN::Queue->jumpqueue([$id,$self->{reqtype}],
6806                                reverse @prereq_tuples);
6807         $self->{later} = "Delayed until after prerequisites";
6808         return 1; # signal success to the queuerunner
6809     }
6810 }
6811
6812 #-> sub CPAN::Distribution::unsat_prereq ;
6813 # return ([Foo=>1],[Bar=>1.2]) for normal modules
6814 # return ([perl=>5.008]) if we need a newer perl than we are running under
6815 sub unsat_prereq {
6816     my($self) = @_;
6817     my $prereq_pm = $self->prereq_pm or return;
6818     my(@need);
6819     my %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}});
6820   NEED: while (my($need_module, $need_version) = each %merged) {
6821         my($have_version,$inst_file);
6822         if ($need_module eq "perl") {
6823             $have_version = $];
6824             $inst_file = $^X;
6825         } else {
6826             my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
6827             next if $nmo->uptodate;
6828             $inst_file = $nmo->inst_file;
6829
6830             # if they have not specified a version, we accept any installed one
6831             if (not defined $need_version or
6832                 $need_version eq "0" or
6833                 $need_version eq "undef") {
6834                 next if defined $inst_file;
6835             }
6836
6837             $have_version = $nmo->inst_version;
6838         }
6839
6840         # We only want to install prereqs if either they're not installed
6841         # or if the installed version is too old. We cannot omit this
6842         # check, because if 'force' is in effect, nobody else will check.
6843         if (defined $inst_file) {
6844             my(@all_requirements) = split /\s*,\s*/, $need_version;
6845             local($^W) = 0;
6846             my $ok = 0;
6847           RQ: for my $rq (@all_requirements) {
6848                 if ($rq =~ s|>=\s*||) {
6849                 } elsif ($rq =~ s|>\s*||) {
6850                     # 2005-12: one user
6851                     if (CPAN::Version->vgt($have_version,$rq)){
6852                         $ok++;
6853                     }
6854                     next RQ;
6855                 } elsif ($rq =~ s|!=\s*||) {
6856                     # 2005-12: no user
6857                     if (CPAN::Version->vcmp($have_version,$rq)){
6858                         $ok++;
6859                         next RQ;
6860                     } else {
6861                         last RQ;
6862                     }
6863                 } elsif ($rq =~ m|<=?\s*|) {
6864                     # 2005-12: no user
6865                     $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])");
6866                     $ok++;
6867                     next RQ;
6868                 }
6869                 if (! CPAN::Version->vgt($rq, $have_version)){
6870                     $ok++;
6871                 }
6872                 CPAN->debug(sprintf("need_module[%s]inst_file[%s]".
6873                                     "inst_version[%s]rq[%s]ok[%d]",
6874                                     $need_module,
6875                                     $inst_file,
6876                                     $have_version,
6877                                     CPAN::Version->readable($rq),
6878                                     $ok,
6879                                    )) if $CPAN::DEBUG;
6880             }
6881             next NEED if $ok == @all_requirements;
6882         }
6883
6884         if ($need_module eq "perl") {
6885             return ["perl", $need_version];
6886         }
6887         if ($self->{sponsored_mods}{$need_module}++){
6888             # We have already sponsored it and for some reason it's still
6889             # not available. So we do nothing. Or what should we do?
6890             # if we push it again, we have a potential infinite loop
6891             next;
6892         }
6893         my $needed_as = exists $prereq_pm->{requires}{$need_module} ? "r" : "b";
6894         push @need, [$need_module,$needed_as];
6895     }
6896     @need;
6897 }
6898
6899 #-> sub CPAN::Distribution::read_yaml ;
6900 sub read_yaml {
6901     my($self) = @_;
6902     return $self->{yaml_content} if exists $self->{yaml_content};
6903     my $build_dir = $self->{build_dir};
6904     my $yaml = File::Spec->catfile($build_dir,"META.yml");
6905     $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
6906     return unless -f $yaml;
6907     eval { $self->{yaml_content} = CPAN->_yaml_loadfile($yaml)->[0]; };
6908     if ($@) {
6909         return; # if we die, then we cannot read YAML's own META.yml
6910     }
6911     if (not exists $self->{yaml_content}{dynamic_config}
6912         or $self->{yaml_content}{dynamic_config}
6913        ) {
6914         $self->{yaml_content} = undef;
6915     }
6916     $self->debug(sprintf "yaml_content[%s]", $self->{yaml_content} || "UNDEF")
6917         if $CPAN::DEBUG;
6918     return $self->{yaml_content};
6919 }
6920
6921 #-> sub CPAN::Distribution::prereq_pm ;
6922 sub prereq_pm {
6923     my($self) = @_;
6924     return $self->{prereq_pm} if
6925         exists $self->{prereq_pm_detected} && $self->{prereq_pm_detected};
6926     return unless $self->{writemakefile}  # no need to have succeeded
6927                                           # but we must have run it
6928         || $self->{modulebuild};
6929     my($req,$breq);
6930     if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
6931         $req =  $yaml->{requires} || {};
6932         $breq =  $yaml->{build_requires} || {};
6933         undef $req unless ref $req eq "HASH" && %$req;
6934         if ($req) {
6935             if ($yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
6936                 my $eummv = do { local $^W = 0; $1+0; };
6937                 if ($eummv < 6.2501) {
6938                     # thanks to Slaven for digging that out: MM before
6939                     # that could be wrong because it could reflect a
6940                     # previous release
6941                     undef $req;
6942                 }
6943             }
6944             my $areq;
6945             my $do_replace;
6946             while (my($k,$v) = each %{$req||{}}) {
6947                 if ($v =~ /\d/) {
6948                     $areq->{$k} = $v;
6949                 } elsif ($k =~ /[A-Za-z]/ &&
6950                          $v =~ /[A-Za-z]/ &&
6951                          $CPAN::META->exists("Module",$v)
6952                         ) {
6953                     $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
6954                                             "requires hash: $k => $v; I'll take both ".
6955                                             "key and value as a module name\n");
6956                     $CPAN::Frontend->mysleep(1);
6957                     $areq->{$k} = 0;
6958                     $areq->{$v} = 0;
6959                     $do_replace++;
6960                 }
6961             }
6962             $req = $areq if $do_replace;
6963         }
6964     }
6965     unless ($req || $breq) {
6966         my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
6967         my $makefile = File::Spec->catfile($build_dir,"Makefile");
6968         my $fh;
6969         if (-f $makefile
6970             and
6971             $fh = FileHandle->new("<$makefile\0")) {
6972             local($/) = "\n";
6973             while (<$fh>) {
6974                 last if /MakeMaker post_initialize section/;
6975                 my($p) = m{^[\#]
6976                            \s+PREREQ_PM\s+=>\s+(.+)
6977                        }x;
6978                 next unless $p;
6979                 # warn "Found prereq expr[$p]";
6980
6981                 #  Regexp modified by A.Speer to remember actual version of file
6982                 #  PREREQ_PM hash key wants, then add to
6983                 while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
6984                     # In case a prereq is mentioned twice, complain.
6985                     if ( defined $req->{$1} ) {
6986                         warn "Warning: PREREQ_PM mentions $1 more than once, ".
6987                             "last mention wins";
6988                     }
6989                     $req->{$1} = $2;
6990                 }
6991                 last;
6992             }
6993         } elsif (-f "Build") {
6994             if ($CPAN::META->has_inst("Module::Build")) {
6995                 eval {
6996                     $req  = Module::Build->current->requires();
6997                     $breq = Module::Build->current->build_requires();
6998                 };
6999                 # this failed for example for HTML::Mason and for
7000                 # Error.pm because they are subclassing Module::Build
7001                 # in their Build.PL in such a way that Module::Build
7002                 # cannot read the _build directory. We DO need a dump
7003                 # command for that.
7004                 if ($@) {
7005                     $CPAN::Frontend
7006                         ->mywarn(
7007                                  sprintf("Warning: while trying to determine ".
7008                                          "prerequisites for %s with the help of ".
7009                                          "Module::Build the following error ".
7010                                          "occurred: '%s'\n\nFalling back to META.yml ".
7011                                          "for prerequisites\n",
7012                                          $self->id,
7013                                          $@
7014                                         ));
7015                     my $build_dir = $self->{build_dir};
7016                     my $yaml = File::Spec->catfile($build_dir,"META.yml");
7017                     if ($yaml = CPAN->_yaml_loadfile($yaml)->[0]) {
7018                         $req =  $yaml->{requires} || {};
7019                         $breq =  $yaml->{build_requires} || {};
7020                     }
7021                 }
7022             }
7023         }
7024     }
7025     if (-f "Build.PL"
7026         && ! -f "Makefile.PL"
7027         && ! exists $req->{"Module::Build"}
7028         && ! $CPAN::META->has_inst("Module::Build")) {
7029         $CPAN::Frontend->mywarn("  Warning: CPAN.pm discovered Module::Build as ".
7030                                 "undeclared prerequisite.\n".
7031                                 "  Adding it now as such.\n"
7032                                );
7033         $CPAN::Frontend->mysleep(5);
7034         $req->{"Module::Build"} = 0;
7035         delete $self->{writemakefile};
7036     }
7037     $self->{prereq_pm_detected}++;
7038     return $self->{prereq_pm} = { requires => $req, build_requires => $breq };
7039 }
7040
7041 #-> sub CPAN::Distribution::test ;
7042 sub test {
7043     my($self) = @_;
7044     $self->make;
7045     if ($CPAN::Signal){
7046       delete $self->{force_update};
7047       return;
7048     }
7049     # warn "XDEBUG: checking for notest: $self->{notest} $self";
7050     if ($self->{notest}) {
7051         $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
7052         return 1;
7053     }
7054
7055     my $make = $self->{modulebuild} ? "Build" : "make";
7056
7057     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
7058                            ? $ENV{PERL5LIB}
7059                            : ($ENV{PERLLIB} || "");
7060
7061     $CPAN::META->set_perl5lib;
7062     local $ENV{MAKEFLAGS}; # protect us from outer make calls
7063
7064     $CPAN::Frontend->myprint("Running $make test\n");
7065     if (my @prereq = $self->unsat_prereq){
7066         unless ($prereq[0][0] eq "perl") {
7067             return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
7068         }
7069     }
7070   EXCUSE: {
7071         my @e;
7072         unless (exists $self->{make} or exists $self->{later}) {
7073             push @e,
7074                 "Make had some problems, won't test";
7075         }
7076
7077         exists $self->{make} and
7078             (
7079              $self->{make}->can("failed") ?
7080              $self->{make}->failed :
7081              $self->{make} =~ /^NO/
7082             ) and push @e, "Can't test without successful make";
7083
7084         $self->{badtestcnt} ||= 0;
7085         $self->{badtestcnt} > 0 and
7086             push @e, "Won't repeat unsuccessful test during this command";
7087
7088         exists $self->{later} and length($self->{later}) and
7089             push @e, $self->{later};
7090
7091         if (exists $self->{build_dir}) {
7092             if ($CPAN::META->{is_tested}{$self->{build_dir}}
7093                 &&
7094                 exists $self->{make_test}
7095                 &&
7096                 !(
7097                   $self->{make_test}->can("failed") ?
7098                   $self->{make_test}->failed :
7099                   $self->{make_test} =~ /^NO/
7100                  )
7101                ) {
7102                 push @e, "Already tested successfully";
7103             }
7104         } elsif (!@e) {
7105             push @e, "Has no own directory";
7106         }
7107
7108         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
7109     }
7110     chdir $self->{'build_dir'} or
7111         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
7112     $self->debug("Changed directory to $self->{'build_dir'}")
7113         if $CPAN::DEBUG;
7114
7115     if ($^O eq 'MacOS') {
7116         Mac::BuildTools::make_test($self);
7117         return;
7118     }
7119
7120     if ($self->{modulebuild}) {
7121         my $v = CPAN::Shell->expand("Module","Test::Harness")->inst_version;
7122         if (CPAN::Version->vlt($v,2.62)) {
7123             $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
7124   '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n});
7125             $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old");
7126             return;
7127         }
7128     }
7129
7130     my $system;
7131     if ($self->{modulebuild}) {
7132         $system = sprintf "%s test", $self->_build_command();
7133     } else {
7134         $system = join " ", $self->_make_command(), "test";
7135     }
7136     my($tests_ok);
7137     my %env;
7138     while (my($k,$v) = each %ENV) {
7139         next unless defined $v;
7140         $env{$k} = $v;
7141     }
7142     local %ENV = %env;
7143     if (my $env = $self->prefs->{test}{env}) {
7144         for my $e (keys %$env) {
7145             $ENV{$e} = $env->{$e};
7146         }
7147     }
7148     my $expect_model = $self->_prefs_with_expect("test");
7149     my $want_expect = 0;
7150     if ( $expect_model && @{$expect_model->{talk}} ) {
7151         my $can_expect = $CPAN::META->has_inst("Expect");
7152         if ($can_expect) {
7153             $want_expect = 1;
7154         } else {
7155             $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
7156                                     "testing without\n");
7157         }
7158     }
7159     my $test_report = CPAN::HandleConfig->prefs_lookup($self,
7160                                                        q{test_report});
7161     my $want_report;
7162     if ($test_report) {
7163         my $can_report = $CPAN::META->has_inst("CPAN::Reporter");
7164         if ($can_report) {
7165             $want_report = 1;
7166         } else {
7167             $CPAN::Frontend->mywarn->("CPAN::Reporter not installed, falling back to ".
7168                                       "testing without\n");
7169         }
7170     }
7171     my $ready_to_report = $want_report;
7172     if ($ready_to_report
7173         && (
7174             substr($self->id,-1,1) eq "."
7175             ||
7176             $self->author->id eq "LOCAL"
7177            )
7178        ) {
7179         $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
7180                                 "for local directories\n");
7181         $ready_to_report = 0;
7182     }
7183     if ($ready_to_report
7184         &&
7185         $self->prefs->{patches}
7186         &&
7187         @{$self->prefs->{patches}}
7188         &&
7189         $self->{patched}
7190        ) {
7191         $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
7192                                 "when the source has been patched\n");
7193         $ready_to_report = 0;
7194     }
7195     if ($want_expect) {
7196         if ($ready_to_report) {
7197             $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ".
7198                                     "not supported when distroprefs specify ".
7199                                     "an interactive test\n");
7200         }
7201         $tests_ok = $self->_run_via_expect($system,$expect_model) == 0;
7202     } elsif ( $ready_to_report ) {
7203         $tests_ok = CPAN::Reporter::test($self, $system);
7204     } else {
7205         $tests_ok = system($system) == 0;
7206     }
7207     $self->introduce_myself;
7208     if ( $tests_ok ) {
7209         {
7210             my @prereq;
7211             for my $m (keys %{$self->{sponsored_mods}}) {
7212                 my $m_obj = CPAN::Shell->expand("Module",$m);
7213                 my $d_obj = $m_obj->distribution;
7214                 if ($d_obj) {
7215                     if (!$d_obj->{make_test}
7216                         ||
7217                         $d_obj->{make_test}->failed){
7218                         #$m_obj->dump;
7219                         push @prereq, $m;
7220                     }
7221                 }
7222             }
7223             if (@prereq){
7224                 my $cnt = @prereq;
7225                 my $which = join ",", @prereq;
7226                 my $verb = $cnt == 1 ? "one dependency not OK ($which)" :
7227                     "$cnt dependencies missing ($which)";
7228                 $CPAN::Frontend->mywarn("Tests succeeded but $verb\n");
7229                 $self->{make_test} = CPAN::Distrostatus->new("NO $verb");
7230                 $self->store_persistent_state;
7231                 return;
7232             }
7233         }
7234
7235         $CPAN::Frontend->myprint("  $system -- OK\n");
7236         $CPAN::META->is_tested($self->{'build_dir'});
7237         $self->{make_test} = CPAN::Distrostatus->new("YES");
7238     } else {
7239         $self->{make_test} = CPAN::Distrostatus->new("NO");
7240         $self->{badtestcnt}++;
7241         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
7242     }
7243     $self->store_persistent_state;
7244 }
7245
7246 sub _prefs_with_expect {
7247     my($self,$where) = @_;
7248     return unless my $prefs = $self->prefs;
7249     return unless my $where_prefs = $prefs->{$where};
7250     if ($where_prefs->{expect}) {
7251         return {
7252                 mode => "expect",
7253                 talk => $where_prefs->{expect},
7254                };
7255     } elsif ($where_prefs->{"expect-in-any-order"}) {
7256         return {
7257                 mode => "expect-in-any-order",
7258                 talk => $where_prefs->{"expect-in-any-order"},
7259                };
7260     }
7261     return;
7262 }
7263
7264 #-> sub CPAN::Distribution::clean ;
7265 sub clean {
7266     my($self) = @_;
7267     my $make = $self->{modulebuild} ? "Build" : "make";
7268     $CPAN::Frontend->myprint("Running $make clean\n");
7269     unless (exists $self->{archived}) {
7270         $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped".
7271                                 "/untarred, nothing done\n");
7272         return 1;
7273     }
7274     unless (exists $self->{build_dir}) {
7275         $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
7276         return 1;
7277     }
7278   EXCUSE: {
7279         my @e;
7280         exists $self->{make_clean} and $self->{make_clean} eq "YES" and
7281             push @e, "make clean already called once";
7282         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
7283     }
7284     chdir $self->{'build_dir'} or
7285         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
7286     $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
7287
7288     if ($^O eq 'MacOS') {
7289         Mac::BuildTools::make_clean($self);
7290         return;
7291     }
7292
7293     my $system;
7294     if ($self->{modulebuild}) {
7295         unless (-f "Build") {
7296             my $cwd = Cwd::cwd;
7297             $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
7298                                     " in cwd[$cwd]. Danger, Will Robinson!");
7299             $CPAN::Frontend->mysleep(5);
7300         }
7301         $system = sprintf "%s clean", $self->_build_command();
7302     } else {
7303         $system  = join " ", $self->_make_command(), "clean";
7304     }
7305     my $system_ok = system($system) == 0;
7306     $self->introduce_myself;
7307     if ( $system_ok ) {
7308       $CPAN::Frontend->myprint("  $system -- OK\n");
7309
7310       # $self->force;
7311
7312       # Jost Krieger pointed out that this "force" was wrong because
7313       # it has the effect that the next "install" on this distribution
7314       # will untar everything again. Instead we should bring the
7315       # object's state back to where it is after untarring.
7316
7317       for my $k (qw(
7318                     force_update
7319                     install
7320                     writemakefile
7321                     make
7322                     make_test
7323                    )) {
7324           delete $self->{$k};
7325       }
7326       $self->{make_clean} = CPAN::Distrostatus->new("YES");
7327
7328     } else {
7329       # Hmmm, what to do if make clean failed?
7330
7331       $self->{make_clean} = CPAN::Distrostatus->new("NO");
7332       $CPAN::Frontend->mywarn(qq{  $system -- NOT OK\n});
7333
7334       # 2006-02-27: seems silly to me to force a make now
7335       # $self->force("make"); # so that this directory won't be used again
7336
7337     }
7338     $self->store_persistent_state;
7339 }
7340
7341 #-> sub CPAN::Distribution::install ;
7342 sub install {
7343     my($self) = @_;
7344     $self->test;
7345     if ($CPAN::Signal){
7346       delete $self->{force_update};
7347       return;
7348     }
7349     my $make = $self->{modulebuild} ? "Build" : "make";
7350     $CPAN::Frontend->myprint("Running $make install\n");
7351   EXCUSE: {
7352         my @e;
7353         unless (exists $self->{make} or exists $self->{later}) {
7354             push @e,
7355                 "Make had some problems, won't install";
7356         }
7357
7358         exists $self->{make} and
7359             (
7360              $self->{make}->can("failed") ?
7361              $self->{make}->failed :
7362              $self->{make} =~ /^NO/
7363             ) and
7364                 push @e, "Make had returned bad status, install seems impossible";
7365
7366         if (exists $self->{build_dir}) {
7367         } elsif (!@e) {
7368             push @e, "Has no own directory";
7369         }
7370
7371         if (exists $self->{make_test} and
7372             (
7373              $self->{make_test}->can("failed") ?
7374              $self->{make_test}->failed :
7375              $self->{make_test} =~ /^NO/
7376             )){
7377             if ($self->{force_update}) {
7378                 $self->{make_test}->text("FAILED but failure ignored because ".
7379                                          "'force' in effect");
7380             } else {
7381                 push @e, "make test had returned bad status, ".
7382                     "won't install without force"
7383             }
7384         }
7385         if (exists $self->{'install'}) {
7386             if ($self->{'install'}->can("text") ?
7387                 $self->{'install'}->text eq "YES" :
7388                 $self->{'install'} =~ /^YES/
7389                ) {
7390                 push @e, "Already done";
7391             } else {
7392                 # comment in Todo on 2006-02-11; maybe retry?
7393                 push @e, "Already tried without success";
7394             }
7395         }
7396
7397         exists $self->{later} and length($self->{later}) and
7398             push @e, $self->{later};
7399
7400         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
7401     }
7402     chdir $self->{'build_dir'} or
7403         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
7404     $self->debug("Changed directory to $self->{'build_dir'}")
7405         if $CPAN::DEBUG;
7406
7407     if ($^O eq 'MacOS') {
7408         Mac::BuildTools::make_install($self);
7409         return;
7410     }
7411
7412     my $system;
7413     if ($self->{modulebuild}) {
7414         my($mbuild_install_build_command) =
7415             exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
7416                 $CPAN::Config->{mbuild_install_build_command} ?
7417                     $CPAN::Config->{mbuild_install_build_command} :
7418                         $self->_build_command();
7419         $system = sprintf("%s install %s",
7420                           $mbuild_install_build_command,
7421                           $CPAN::Config->{mbuild_install_arg},
7422                          );
7423     } else {
7424         my($make_install_make_command) =
7425             CPAN::HandleConfig->prefs_lookup($self,
7426                                              q{make_install_make_command})
7427                   || $self->_make_command();
7428         $system = sprintf("%s install %s",
7429                           $make_install_make_command,
7430                           $CPAN::Config->{make_install_arg},
7431                          );
7432     }
7433
7434     my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 ";
7435     my $brip = CPAN::HandleConfig->prefs_lookup($self,
7436                                                 q{build_requires_install_policy});
7437     $brip ||="ask/yes";
7438     my $id = $self->id;
7439     my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command
7440     my $want_install = "yes";
7441     if ($reqtype eq "b") {
7442         if ($brip eq "no") {
7443             $want_install = "no";
7444         } elsif ($brip =~ m|^ask/(.+)|) {
7445             my $default = $1;
7446             $default = "yes" unless $default =~ /^(y|n)/i;
7447             $want_install =
7448                 CPAN::Shell::colorable_makemaker_prompt
7449                       ("$id is just needed temporarily during building or testing. ".
7450                        "Do you want to install it permanently? (Y/n)",
7451                        $default);
7452         }
7453     }
7454     unless ($want_install =~ /^y/i) {
7455         my $is_only = "is only 'build_requires'";
7456         $CPAN::Frontend->mywarn("Not installing because $is_only\n");
7457         $self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
7458         delete $self->{force_update};
7459         return;
7460     }
7461     my($pipe) = FileHandle->new("$system $stderr |");
7462     my($makeout) = "";
7463     while (<$pipe>){
7464         print $_; # intentionally NOT use Frontend->myprint because it
7465                   # looks irritating when we markup in color what we
7466                   # just pass through from an external program
7467         $makeout .= $_;
7468     }
7469     $pipe->close;
7470     my $close_ok = $? == 0;
7471     $self->introduce_myself;
7472     if ( $close_ok ) {
7473         $CPAN::Frontend->myprint("  $system -- OK\n");
7474         $CPAN::META->is_installed($self->{build_dir});
7475         return $self->{install} = CPAN::Distrostatus->new("YES");
7476     } else {
7477         $self->{install} = CPAN::Distrostatus->new("NO");
7478         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
7479         my $mimc =
7480             CPAN::HandleConfig->prefs_lookup($self,
7481                                              q{make_install_make_command});
7482         if (
7483             $makeout =~ /permission/s
7484             && $> > 0
7485             && (
7486                 ! $mimc
7487                 || $mimc eq (CPAN::HandleConfig->prefs_lookup($self,
7488                                                               q{make}))
7489                )
7490            ) {
7491             $CPAN::Frontend->myprint(
7492                                      qq{----\n}.
7493                                      qq{  You may have to su }.
7494                                      qq{to root to install the package\n}.
7495                                      qq{  (Or you may want to run something like\n}.
7496                                      qq{    o conf make_install_make_command 'sudo make'\n}.
7497                                      qq{  to raise your permissions.}
7498                                     );
7499         }
7500     }
7501     delete $self->{force_update};
7502     $self->store_persistent_state;
7503 }
7504
7505 sub introduce_myself {
7506     my($self) = @_;
7507     $CPAN::Frontend->myprint(sprintf("  %s\n",$self->pretty_id));
7508 }
7509
7510 #-> sub CPAN::Distribution::dir ;
7511 sub dir {
7512     shift->{'build_dir'};
7513 }
7514
7515 #-> sub CPAN::Distribution::perldoc ;
7516 sub perldoc {
7517     my($self) = @_;
7518
7519     my($dist) = $self->id;
7520     my $package = $self->called_for;
7521
7522     $self->_display_url( $CPAN::Defaultdocs . $package );
7523 }
7524
7525 #-> sub CPAN::Distribution::_check_binary ;
7526 sub _check_binary {
7527     my ($dist,$shell,$binary) = @_;
7528     my ($pid,$out);
7529
7530     $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
7531       if $CPAN::DEBUG;
7532
7533     if ($CPAN::META->has_inst("File::Which")) {
7534         return File::Which::which($binary);
7535     } else {
7536         local *README;
7537         $pid = open README, "which $binary|"
7538             or $CPAN::Frontend->mywarn(qq{Could not fork 'which $binary': $!\n});
7539         return unless $pid;
7540         while (<README>) {
7541             $out .= $_;
7542         }
7543         close README
7544             or $CPAN::Frontend->mywarn("Could not run 'which $binary': $!\n")
7545                 and return;
7546     }
7547
7548     $CPAN::Frontend->myprint(qq{   + $out \n})
7549       if $CPAN::DEBUG && $out;
7550
7551     return $out;
7552 }
7553
7554 #-> sub CPAN::Distribution::_display_url ;
7555 sub _display_url {
7556     my($self,$url) = @_;
7557     my($res,$saved_file,$pid,$out);
7558
7559     $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
7560       if $CPAN::DEBUG;
7561
7562     # should we define it in the config instead?
7563     my $html_converter = "html2text";
7564
7565     my $web_browser = $CPAN::Config->{'lynx'} || undef;
7566     my $web_browser_out = $web_browser
7567       ? CPAN::Distribution->_check_binary($self,$web_browser)
7568         : undef;
7569
7570     if ($web_browser_out) {
7571         # web browser found, run the action
7572         my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
7573         $CPAN::Frontend->myprint(qq{system[$browser $url]})
7574           if $CPAN::DEBUG;
7575         $CPAN::Frontend->myprint(qq{
7576 Displaying URL
7577   $url
7578 with browser $browser
7579 });
7580         $CPAN::Frontend->mysleep(1);
7581         system("$browser $url");
7582         if ($saved_file) { 1 while unlink($saved_file) }
7583     } else {
7584         # web browser not found, let's try text only
7585         my $html_converter_out =
7586           CPAN::Distribution->_check_binary($self,$html_converter);
7587         $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out);
7588
7589         if ($html_converter_out ) {
7590             # html2text found, run it
7591             $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
7592             $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n})
7593                 unless defined($saved_file);
7594
7595             local *README;
7596             $pid = open README, "$html_converter $saved_file |"
7597               or $CPAN::Frontend->mydie(qq{
7598 Could not fork '$html_converter $saved_file': $!});
7599             my($fh,$filename);
7600             if ($CPAN::META->has_inst("File::Temp")) {
7601                 $fh = File::Temp->new(
7602                                       template => 'cpan_htmlconvert_XXXX',
7603                                       suffix => '.txt',
7604                                       unlink => 0,
7605                                      );
7606                 $filename = $fh->filename;
7607             } else {
7608                 $filename = "cpan_htmlconvert_$$.txt";
7609                 $fh = FileHandle->new();
7610                 open $fh, ">$filename" or die;
7611             }
7612             while (<README>) {
7613                 $fh->print($_);
7614             }
7615             close README or
7616                 $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
7617             my $tmpin = $fh->filename;
7618             $CPAN::Frontend->myprint(sprintf(qq{
7619 Run '%s %s' and
7620 saved output to %s\n},
7621                                              $html_converter,
7622                                              $saved_file,
7623                                              $tmpin,
7624                                             )) if $CPAN::DEBUG;
7625             close $fh;
7626             local *FH;
7627             open FH, $tmpin
7628                 or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
7629             my $fh_pager = FileHandle->new;
7630             local($SIG{PIPE}) = "IGNORE";
7631             my $pager = $CPAN::Config->{'pager'} || "cat";
7632             $fh_pager->open("|$pager")
7633                 or $CPAN::Frontend->mydie(qq{
7634 Could not open pager '$pager': $!});
7635             $CPAN::Frontend->myprint(qq{
7636 Displaying URL
7637   $url
7638 with pager "$pager"
7639 });
7640             $CPAN::Frontend->mysleep(1);
7641             $fh_pager->print(<FH>);
7642             $fh_pager->close;
7643         } else {
7644             # coldn't find the web browser or html converter
7645             $CPAN::Frontend->myprint(qq{
7646 You need to install lynx or $html_converter to use this feature.});
7647         }
7648     }
7649 }
7650
7651 #-> sub CPAN::Distribution::_getsave_url ;
7652 sub _getsave_url {
7653     my($dist, $shell, $url) = @_;
7654
7655     $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
7656       if $CPAN::DEBUG;
7657
7658     my($fh,$filename);
7659     if ($CPAN::META->has_inst("File::Temp")) {
7660         $fh = File::Temp->new(
7661                               template => "cpan_getsave_url_XXXX",
7662                               suffix => ".html",
7663                               unlink => 0,
7664                              );
7665         $filename = $fh->filename;
7666     } else {
7667         $fh = FileHandle->new;
7668         $filename = "cpan_getsave_url_$$.html";
7669     }
7670     my $tmpin = $filename;
7671     if ($CPAN::META->has_usable('LWP')) {
7672         $CPAN::Frontend->myprint("Fetching with LWP:
7673   $url
7674 ");
7675         my $Ua;
7676         CPAN::LWP::UserAgent->config;
7677         eval { $Ua = CPAN::LWP::UserAgent->new; };
7678         if ($@) {
7679             $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
7680             return;
7681         } else {
7682             my($var);
7683             $Ua->proxy('http', $var)
7684                 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
7685             $Ua->no_proxy($var)
7686                 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
7687         }
7688
7689         my $req = HTTP::Request->new(GET => $url);
7690         $req->header('Accept' => 'text/html');
7691         my $res = $Ua->request($req);
7692         if ($res->is_success) {
7693             $CPAN::Frontend->myprint(" + request successful.\n")
7694                 if $CPAN::DEBUG;
7695             print $fh $res->content;
7696             close $fh;
7697             $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
7698                 if $CPAN::DEBUG;
7699             return $tmpin;
7700         } else {
7701             $CPAN::Frontend->myprint(sprintf(
7702                                              "LWP failed with code[%s], message[%s]\n",
7703                                              $res->code,
7704                                              $res->message,
7705                                             ));
7706             return;
7707         }
7708     } else {
7709         $CPAN::Frontend->mywarn("  LWP not available\n");
7710         return;
7711     }
7712 }
7713
7714 # sub CPAN::Distribution::_build_command
7715 sub _build_command {
7716     my($self) = @_;
7717     if ($^O eq "MSWin32") { # special code needed at least up to
7718                             # Module::Build 0.2611 and 0.2706; a fix
7719                             # in M:B has been promised 2006-01-30
7720         my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
7721         return "$perl ./Build";
7722     }
7723     return "./Build";
7724 }
7725
7726 package CPAN::Bundle;
7727 use strict;
7728
7729 sub look {
7730     my $self = shift;
7731     $CPAN::Frontend->myprint($self->as_string);
7732 }
7733
7734 sub undelay {
7735     my $self = shift;
7736     delete $self->{later};
7737     for my $c ( $self->contains ) {
7738         my $obj = CPAN::Shell->expandany($c) or next;
7739         $obj->undelay;
7740     }
7741 }
7742
7743 # mark as dirty/clean
7744 #-> sub CPAN::Bundle::color_cmd_tmps ;
7745 sub color_cmd_tmps {
7746     my($self) = shift;
7747     my($depth) = shift || 0;
7748     my($color) = shift || 0;
7749     my($ancestors) = shift || [];
7750     # a module needs to recurse to its cpan_file, a distribution needs
7751     # to recurse into its prereq_pms, a bundle needs to recurse into its modules
7752
7753     return if exists $self->{incommandcolor}
7754         && $self->{incommandcolor}==$color;
7755     if ($depth>=100){
7756         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
7757     }
7758     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
7759
7760     for my $c ( $self->contains ) {
7761         my $obj = CPAN::Shell->expandany($c) or next;
7762         CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
7763         $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
7764     }
7765     if ($color==0) {
7766         delete $self->{badtestcnt};
7767     }
7768     $self->{incommandcolor} = $color;
7769 }
7770
7771 #-> sub CPAN::Bundle::as_string ;
7772 sub as_string {
7773     my($self) = @_;
7774     $self->contains;
7775     # following line must be "=", not "||=" because we have a moving target
7776     $self->{INST_VERSION} = $self->inst_version;
7777     return $self->SUPER::as_string;
7778 }
7779
7780 #-> sub CPAN::Bundle::contains ;
7781 sub contains {
7782     my($self) = @_;
7783     my($inst_file) = $self->inst_file || "";
7784     my($id) = $self->id;
7785     $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
7786     if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) {
7787         undef $inst_file;
7788     }
7789     unless ($inst_file) {
7790         # Try to get at it in the cpan directory
7791         $self->debug("no inst_file") if $CPAN::DEBUG;
7792         my $cpan_file;
7793         $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
7794               $cpan_file = $self->cpan_file;
7795         if ($cpan_file eq "N/A") {
7796             $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
7797   Maybe stale symlink? Maybe removed during session? Giving up.\n");
7798         }
7799         my $dist = $CPAN::META->instance('CPAN::Distribution',
7800                                          $self->cpan_file);
7801         $dist->get;
7802         $self->debug("id[$dist->{ID}]") if $CPAN::DEBUG;
7803         my($todir) = $CPAN::Config->{'cpan_home'};
7804         my(@me,$from,$to,$me);
7805         @me = split /::/, $self->id;
7806         $me[-1] .= ".pm";
7807         $me = File::Spec->catfile(@me);
7808         $from = $self->find_bundle_file($dist->{'build_dir'},join('/',@me));
7809         $to = File::Spec->catfile($todir,$me);
7810         File::Path::mkpath(File::Basename::dirname($to));
7811         File::Copy::copy($from, $to)
7812               or Carp::confess("Couldn't copy $from to $to: $!");
7813         $inst_file = $to;
7814     }
7815     my @result;
7816     my $fh = FileHandle->new;
7817     local $/ = "\n";
7818     open($fh,$inst_file) or die "Could not open '$inst_file': $!";
7819     my $in_cont = 0;
7820     $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
7821     while (<$fh>) {
7822         $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
7823             m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
7824         next unless $in_cont;
7825         next if /^=/;
7826         s/\#.*//;
7827         next if /^\s+$/;
7828         chomp;
7829         push @result, (split " ", $_, 2)[0];
7830     }
7831     close $fh;
7832     delete $self->{STATUS};
7833     $self->{CONTAINS} = \@result;
7834     $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
7835     unless (@result) {
7836         $CPAN::Frontend->mywarn(qq{
7837 The bundle file "$inst_file" may be a broken
7838 bundlefile. It seems not to contain any bundle definition.
7839 Please check the file and if it is bogus, please delete it.
7840 Sorry for the inconvenience.
7841 });
7842     }
7843     @result;
7844 }
7845
7846 #-> sub CPAN::Bundle::find_bundle_file
7847 # $where is in local format, $what is in unix format
7848 sub find_bundle_file {
7849     my($self,$where,$what) = @_;
7850     $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
7851 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
7852 ###    my $bu = File::Spec->catfile($where,$what);
7853 ###    return $bu if -f $bu;
7854     my $manifest = File::Spec->catfile($where,"MANIFEST");
7855     unless (-f $manifest) {
7856         require ExtUtils::Manifest;
7857         my $cwd = CPAN::anycwd();
7858         $self->safe_chdir($where);
7859         ExtUtils::Manifest::mkmanifest();
7860         $self->safe_chdir($cwd);
7861     }
7862     my $fh = FileHandle->new($manifest)
7863         or Carp::croak("Couldn't open $manifest: $!");
7864     local($/) = "\n";
7865     my $bundle_filename = $what;
7866     $bundle_filename =~ s|Bundle.*/||;
7867     my $bundle_unixpath;
7868     while (<$fh>) {
7869         next if /^\s*\#/;
7870         my($file) = /(\S+)/;
7871         if ($file =~ m|\Q$what\E$|) {
7872             $bundle_unixpath = $file;
7873             # return File::Spec->catfile($where,$bundle_unixpath); # bad
7874             last;
7875         }
7876         # retry if she managed to have no Bundle directory
7877         $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
7878     }
7879     return File::Spec->catfile($where, split /\//, $bundle_unixpath)
7880         if $bundle_unixpath;
7881     Carp::croak("Couldn't find a Bundle file in $where");
7882 }
7883
7884 # needs to work quite differently from Module::inst_file because of
7885 # cpan_home/Bundle/ directory and the possibility that we have
7886 # shadowing effect. As it makes no sense to take the first in @INC for
7887 # Bundles, we parse them all for $VERSION and take the newest.
7888
7889 #-> sub CPAN::Bundle::inst_file ;
7890 sub inst_file {
7891     my($self) = @_;
7892     my($inst_file);
7893     my(@me);
7894     @me = split /::/, $self->id;
7895     $me[-1] .= ".pm";
7896     my($incdir,$bestv);
7897     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
7898         my $bfile = File::Spec->catfile($incdir, @me);
7899         CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
7900         next unless -f $bfile;
7901         my $foundv = MM->parse_version($bfile);
7902         if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
7903             $self->{INST_FILE} = $bfile;
7904             $self->{INST_VERSION} = $bestv = $foundv;
7905         }
7906     }
7907     $self->{INST_FILE};
7908 }
7909
7910 #-> sub CPAN::Bundle::inst_version ;
7911 sub inst_version {
7912     my($self) = @_;
7913     $self->inst_file; # finds INST_VERSION as side effect
7914     $self->{INST_VERSION};
7915 }
7916
7917 #-> sub CPAN::Bundle::rematein ;
7918 sub rematein {
7919     my($self,$meth) = @_;
7920     $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
7921     my($id) = $self->id;
7922     Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
7923         unless $self->inst_file || $self->cpan_file;
7924     my($s,%fail);
7925     for $s ($self->contains) {
7926         my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
7927             $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
7928         if ($type eq 'CPAN::Distribution') {
7929             $CPAN::Frontend->mywarn(qq{
7930 The Bundle }.$self->id.qq{ contains
7931 explicitly a file '$s'.
7932 Going to $meth that.
7933 });
7934             $CPAN::Frontend->mysleep(5);
7935         }
7936         # possibly noisy action:
7937         $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
7938         my $obj = $CPAN::META->instance($type,$s);
7939         $obj->{reqtype} = $self->{reqtype};
7940         $obj->$meth();
7941         if ($obj->isa('CPAN::Bundle')
7942             &&
7943             exists $obj->{install_failed}
7944             &&
7945             ref($obj->{install_failed}) eq "HASH"
7946            ) {
7947           for (keys %{$obj->{install_failed}}) {
7948             $self->{install_failed}{$_} = undef; # propagate faiure up
7949                                                  # to me in a
7950                                                  # recursive call
7951             $fail{$s} = 1; # the bundle itself may have succeeded but
7952                            # not all children
7953           }
7954         } else {
7955           my $success;
7956           $success = $obj->can("uptodate") ? $obj->uptodate : 0;
7957           $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
7958           if ($success) {
7959             delete $self->{install_failed}{$s};
7960           } else {
7961             $fail{$s} = 1;
7962           }
7963         }
7964     }
7965
7966     # recap with less noise
7967     if ( $meth eq "install" ) {
7968         if (%fail) {
7969             require Text::Wrap;
7970             my $raw = sprintf(qq{Bundle summary:
7971 The following items in bundle %s had installation problems:},
7972                               $self->id
7973                              );
7974             $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
7975             $CPAN::Frontend->myprint("\n");
7976             my $paragraph = "";
7977             my %reported;
7978             for $s ($self->contains) {
7979               if ($fail{$s}){
7980                 $paragraph .= "$s ";
7981                 $self->{install_failed}{$s} = undef;
7982                 $reported{$s} = undef;
7983               }
7984             }
7985             my $report_propagated;
7986             for $s (sort keys %{$self->{install_failed}}) {
7987               next if exists $reported{$s};
7988               $paragraph .= "and the following items had problems
7989 during recursive bundle calls: " unless $report_propagated++;
7990               $paragraph .= "$s ";
7991             }
7992             $CPAN::Frontend->myprint(Text::Wrap::fill("  ","  ",$paragraph));
7993             $CPAN::Frontend->myprint("\n");
7994         } else {
7995             $self->{'install'} = 'YES';
7996         }
7997     }
7998 }
7999
8000 # If a bundle contains another that contains an xs_file we have here,
8001 # we just don't bother I suppose
8002 #-> sub CPAN::Bundle::xs_file
8003 sub xs_file {
8004     return 0;
8005 }
8006
8007 #-> sub CPAN::Bundle::force ;
8008 sub force   { shift->rematein('force',@_); }
8009 #-> sub CPAN::Bundle::notest ;
8010 sub notest  { shift->rematein('notest',@_); }
8011 #-> sub CPAN::Bundle::get ;
8012 sub get     { shift->rematein('get',@_); }
8013 #-> sub CPAN::Bundle::make ;
8014 sub make    { shift->rematein('make',@_); }
8015 #-> sub CPAN::Bundle::test ;
8016 sub test    {
8017     my $self = shift;
8018     $self->{badtestcnt} ||= 0;
8019     $self->rematein('test',@_);
8020 }
8021 #-> sub CPAN::Bundle::install ;
8022 sub install {
8023   my $self = shift;
8024   $self->rematein('install',@_);
8025 }
8026 #-> sub CPAN::Bundle::clean ;
8027 sub clean   { shift->rematein('clean',@_); }
8028
8029 #-> sub CPAN::Bundle::uptodate ;
8030 sub uptodate {
8031     my($self) = @_;
8032     return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
8033     my $c;
8034     foreach $c ($self->contains) {
8035         my $obj = CPAN::Shell->expandany($c);
8036         return 0 unless $obj->uptodate;
8037     }
8038     return 1;
8039 }
8040
8041 #-> sub CPAN::Bundle::readme ;
8042 sub readme  {
8043     my($self) = @_;
8044     my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
8045 No File found for bundle } . $self->id . qq{\n}), return;
8046     $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
8047     $CPAN::META->instance('CPAN::Distribution',$file)->readme;
8048 }
8049
8050 package CPAN::Module;
8051 use strict;
8052
8053 # Accessors
8054 # sub CPAN::Module::userid
8055 sub userid {
8056     my $self = shift;
8057     my $ro = $self->ro;
8058     return unless $ro;
8059     return $ro->{userid} || $ro->{CPAN_USERID};
8060 }
8061 # sub CPAN::Module::description
8062 sub description {
8063     my $self = shift;
8064     my $ro = $self->ro or return "";
8065     $ro->{description}
8066 }
8067
8068 sub distribution {
8069     my($self) = @_;
8070     CPAN::Shell->expand("Distribution",$self->cpan_file);
8071 }
8072
8073 # sub CPAN::Module::undelay
8074 sub undelay {
8075     my $self = shift;
8076     delete $self->{later};
8077     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
8078         $dist->undelay;
8079     }
8080 }
8081
8082 # mark as dirty/clean
8083 #-> sub CPAN::Module::color_cmd_tmps ;
8084 sub color_cmd_tmps {
8085     my($self) = shift;
8086     my($depth) = shift || 0;
8087     my($color) = shift || 0;
8088     my($ancestors) = shift || [];
8089     # a module needs to recurse to its cpan_file
8090
8091     return if exists $self->{incommandcolor}
8092         && $self->{incommandcolor}==$color;
8093     return if $depth>=1 && $self->uptodate;
8094     if ($depth>=100){
8095         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
8096     }
8097     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
8098
8099     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
8100         $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
8101     }
8102     if ($color==0) {
8103         delete $self->{badtestcnt};
8104     }
8105     $self->{incommandcolor} = $color;
8106 }
8107
8108 #-> sub CPAN::Module::as_glimpse ;
8109 sub as_glimpse {
8110     my($self) = @_;
8111     my(@m);
8112     my $class = ref($self);
8113     $class =~ s/^CPAN:://;
8114     my $color_on = "";
8115     my $color_off = "";
8116     if (
8117         $CPAN::Shell::COLOR_REGISTERED
8118         &&
8119         $CPAN::META->has_inst("Term::ANSIColor")
8120         &&
8121         $self->description
8122        ) {
8123         $color_on = Term::ANSIColor::color("green");
8124         $color_off = Term::ANSIColor::color("reset");
8125     }
8126     my $uptodateness = " ";
8127     if ($class eq "Bundle") {
8128     } elsif ($self->uptodate) {
8129         $uptodateness = "=";
8130     } elsif ($self->inst_version) {
8131         $uptodateness = "<";
8132     }
8133     push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n",
8134                      $class,
8135                      $uptodateness,
8136                      $color_on,
8137                      $self->id,
8138                      $color_off,
8139                      ($self->distribution ?
8140                       $self->distribution->pretty_id :
8141                       $self->cpan_userid
8142                      ),
8143                     );
8144     join "", @m;
8145 }
8146
8147 #-> sub CPAN::Module::dslip_status
8148 sub dslip_status {
8149     my($self) = @_;
8150     my($stat);
8151     @{$stat->{D}}{qw,i c a b R M S,}     = qw,idea
8152                                               pre-alpha alpha beta released
8153                                               mature standard,;
8154     @{$stat->{S}}{qw,m d u n a,}         = qw,mailing-list
8155                                               developer comp.lang.perl.*
8156                                               none abandoned,;
8157     @{$stat->{L}}{qw,p c + o h,}         = qw,perl C C++ other hybrid,;
8158     @{$stat->{I}}{qw,f r O p h n,}       = qw,functions
8159                                               references+ties
8160                                               object-oriented pragma
8161                                               hybrid none,;
8162     @{$stat->{P}}{qw,p g l b a o d r n,} = qw,Standard-Perl
8163                                               GPL LGPL
8164                                               BSD Artistic
8165                                               open-source
8166                                               distribution_allowed
8167                                               restricted_distribution
8168                                               no_licence,;
8169     for my $x (qw(d s l i p)) {
8170         $stat->{$x}{' '} = 'unknown';
8171         $stat->{$x}{'?'} = 'unknown';
8172     }
8173     my $ro = $self->ro;
8174     return +{} unless $ro && $ro->{statd};
8175     return {
8176             D  => $ro->{statd},
8177             S  => $ro->{stats},
8178             L  => $ro->{statl},
8179             I  => $ro->{stati},
8180             P  => $ro->{statp},
8181             DV => $stat->{D}{$ro->{statd}},
8182             SV => $stat->{S}{$ro->{stats}},
8183             LV => $stat->{L}{$ro->{statl}},
8184             IV => $stat->{I}{$ro->{stati}},
8185             PV => $stat->{P}{$ro->{statp}},
8186            };
8187 }
8188
8189 #-> sub CPAN::Module::as_string ;
8190 sub as_string {
8191     my($self) = @_;
8192     my(@m);
8193     CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
8194     my $class = ref($self);
8195     $class =~ s/^CPAN:://;
8196     local($^W) = 0;
8197     push @m, $class, " id = $self->{ID}\n";
8198     my $sprintf = "    %-12s %s\n";
8199     push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
8200         if $self->description;
8201     my $sprintf2 = "    %-12s %s (%s)\n";
8202     my($userid);
8203     $userid = $self->userid;
8204     if ( $userid ){
8205         my $author;
8206         if ($author = CPAN::Shell->expand('Author',$userid)) {
8207           my $email = "";
8208           my $m; # old perls
8209           if ($m = $author->email) {
8210             $email = " <$m>";
8211           }
8212           push @m, sprintf(
8213                            $sprintf2,
8214                            'CPAN_USERID',
8215                            $userid,
8216                            $author->fullname . $email
8217                           );
8218         }
8219     }
8220     push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
8221         if $self->cpan_version;
8222     if (my $cpan_file = $self->cpan_file){
8223         push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
8224         if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
8225             my $upload_date = $dist->upload_date;
8226             if ($upload_date) {
8227                 push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
8228             }
8229         }
8230     }
8231     my $sprintf3 = "    %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n";
8232     my $dslip = $self->dslip_status;
8233     push @m, sprintf(
8234                      $sprintf3,
8235                      'DSLIP_STATUS',
8236                      @{$dslip}{qw(D S L I P DV SV LV IV PV)},
8237                     ) if $dslip->{D};
8238     my $local_file = $self->inst_file;
8239     unless ($self->{MANPAGE}) {
8240         my $manpage;
8241         if ($local_file) {
8242             $manpage = $self->manpage_headline($local_file);
8243         } else {
8244             # If we have already untarred it, we should look there
8245             my $dist = $CPAN::META->instance('CPAN::Distribution',
8246                                              $self->cpan_file);
8247             # warn "dist[$dist]";
8248             # mff=manifest file; mfh=manifest handle
8249             my($mff,$mfh);
8250             if (
8251                 $dist->{build_dir}
8252                 and
8253                 (-f  ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
8254                 and
8255                 $mfh = FileHandle->new($mff)
8256                ) {
8257                 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
8258                 my $lfre = $self->id; # local file RE
8259                 $lfre =~ s/::/./g;
8260                 $lfre .= "\\.pm\$";
8261                 my($lfl); # local file file
8262                 local $/ = "\n";
8263                 my(@mflines) = <$mfh>;
8264                 for (@mflines) {
8265                     s/^\s+//;
8266                     s/\s.*//s;
8267                 }
8268                 while (length($lfre)>5 and !$lfl) {
8269                     ($lfl) = grep /$lfre/, @mflines;
8270                     CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
8271                     $lfre =~ s/.+?\.//;
8272                 }
8273                 $lfl =~ s/\s.*//; # remove comments
8274                 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
8275                 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
8276                 # warn "lfl_abs[$lfl_abs]";
8277                 if (-f $lfl_abs) {
8278                     $manpage = $self->manpage_headline($lfl_abs);
8279                 }
8280             }
8281         }
8282         $self->{MANPAGE} = $manpage if $manpage;
8283     }
8284     my($item);
8285     for $item (qw/MANPAGE/) {
8286         push @m, sprintf($sprintf, $item, $self->{$item})
8287             if exists $self->{$item};
8288     }
8289     for $item (qw/CONTAINS/) {
8290         push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
8291             if exists $self->{$item} && @{$self->{$item}};
8292     }
8293     push @m, sprintf($sprintf, 'INST_FILE',
8294                      $local_file || "(not installed)");
8295     push @m, sprintf($sprintf, 'INST_VERSION',
8296                      $self->inst_version) if $local_file;
8297     join "", @m, "\n";
8298 }
8299
8300 sub manpage_headline {
8301   my($self,$local_file) = @_;
8302   my(@local_file) = $local_file;
8303   $local_file =~ s/\.pm(?!\n)\Z/.pod/;
8304   push @local_file, $local_file;
8305   my(@result,$locf);
8306   for $locf (@local_file) {
8307     next unless -f $locf;
8308     my $fh = FileHandle->new($locf)
8309         or $Carp::Frontend->mydie("Couldn't open $locf: $!");
8310     my $inpod = 0;
8311     local $/ = "\n";
8312     while (<$fh>) {
8313       $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
8314           m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
8315       next unless $inpod;
8316       next if /^=/;
8317       next if /^\s+$/;
8318       chomp;
8319       push @result, $_;
8320     }
8321     close $fh;
8322     last if @result;
8323   }
8324   for (@result) {
8325       s/^\s+//;
8326       s/\s+$//;
8327   }
8328   join " ", @result;
8329 }
8330
8331 #-> sub CPAN::Module::cpan_file ;
8332 # Note: also inherited by CPAN::Bundle
8333 sub cpan_file {
8334     my $self = shift;
8335     # CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
8336     unless ($self->ro) {
8337         CPAN::Index->reload;
8338     }
8339     my $ro = $self->ro;
8340     if ($ro && defined $ro->{CPAN_FILE}){
8341         return $ro->{CPAN_FILE};
8342     } else {
8343         my $userid = $self->userid;
8344         if ( $userid ) {
8345             if ($CPAN::META->exists("CPAN::Author",$userid)) {
8346                 my $author = $CPAN::META->instance("CPAN::Author",
8347                                                    $userid);
8348                 my $fullname = $author->fullname;
8349                 my $email = $author->email;
8350                 unless (defined $fullname && defined $email) {
8351                     return sprintf("Contact Author %s",
8352                                    $userid,
8353                                   );
8354                 }
8355                 return "Contact Author $fullname <$email>";
8356             } else {
8357                 return "Contact Author $userid (Email address not available)";
8358             }
8359         } else {
8360             return "N/A";
8361         }
8362     }
8363 }
8364
8365 #-> sub CPAN::Module::cpan_version ;
8366 sub cpan_version {
8367     my $self = shift;
8368
8369     my $ro = $self->ro;
8370     unless ($ro) {
8371         # Can happen with modules that are not on CPAN
8372         $ro = {};
8373     }
8374     $ro->{CPAN_VERSION} = 'undef'
8375         unless defined $ro->{CPAN_VERSION};
8376     $ro->{CPAN_VERSION};
8377 }
8378
8379 #-> sub CPAN::Module::force ;
8380 sub force {
8381     my($self) = @_;
8382     $self->{'force_update'}++;
8383 }
8384
8385 sub notest {
8386     my($self) = @_;
8387     # warn "XDEBUG: set notest for Module";
8388     $self->{'notest'}++;
8389 }
8390
8391 #-> sub CPAN::Module::rematein ;
8392 sub rematein {
8393     my($self,$meth) = @_;
8394     $CPAN::Frontend->myprint(sprintf("Running %s for module '%s'\n",
8395                                      $meth,
8396                                      $self->id));
8397     my $cpan_file = $self->cpan_file;
8398     if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
8399       $CPAN::Frontend->mywarn(sprintf qq{
8400   The module %s isn\'t available on CPAN.
8401
8402   Either the module has not yet been uploaded to CPAN, or it is
8403   temporary unavailable. Please contact the author to find out
8404   more about the status. Try 'i %s'.
8405 },
8406                               $self->id,
8407                               $self->id,
8408                              );
8409       return;
8410     }
8411     my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
8412     $pack->called_for($self->id);
8413     $pack->force($meth) if exists $self->{'force_update'};
8414     $pack->notest($meth) if exists $self->{'notest'};
8415
8416     $pack->{reqtype} ||= "";
8417     CPAN->debug("dist-reqtype[$pack->{reqtype}]".
8418                 "self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG;
8419         if ($pack->{reqtype}) {
8420             if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) {
8421                 $pack->{reqtype} = $self->{reqtype};
8422                 if (
8423                     exists $pack->{install}
8424                     &&
8425                     (
8426                      $pack->{install}->can("failed") ?
8427                      $pack->{install}->failed :
8428                      $pack->{install} =~ /^NO/
8429                     )
8430                    ) {
8431                     delete $pack->{install};
8432                     $CPAN::Frontend->mywarn
8433                         ("Promoting $pack->{ID} from 'build_requires' to 'requires'");
8434                 }
8435             }
8436         } else {
8437             $pack->{reqtype} = $self->{reqtype};
8438         }
8439
8440     eval {
8441         $pack->$meth();
8442     };
8443     my $err = $@;
8444     $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
8445     $pack->unnotest if $pack->can("unnotest") && exists $self->{'notest'};
8446     delete $self->{'force_update'};
8447     delete $self->{'notest'};
8448     if ($err) {
8449         die $err;
8450     }
8451 }
8452
8453 #-> sub CPAN::Module::perldoc ;
8454 sub perldoc { shift->rematein('perldoc') }
8455 #-> sub CPAN::Module::readme ;
8456 sub readme  { shift->rematein('readme') }
8457 #-> sub CPAN::Module::look ;
8458 sub look    { shift->rematein('look') }
8459 #-> sub CPAN::Module::cvs_import ;
8460 sub cvs_import { shift->rematein('cvs_import') }
8461 #-> sub CPAN::Module::get ;
8462 sub get     { shift->rematein('get',@_) }
8463 #-> sub CPAN::Module::make ;
8464 sub make    { shift->rematein('make') }
8465 #-> sub CPAN::Module::test ;
8466 sub test   {
8467     my $self = shift;
8468     $self->{badtestcnt} ||= 0;
8469     $self->rematein('test',@_);
8470 }
8471 #-> sub CPAN::Module::uptodate ;
8472 sub uptodate {
8473     my($self) = @_;
8474     local($_); # protect against a bug in MakeMaker 6.17
8475     my($latest) = $self->cpan_version;
8476     $latest ||= 0;
8477     my($inst_file) = $self->inst_file;
8478     my($have) = 0;
8479     if (defined $inst_file) {
8480         $have = $self->inst_version;
8481     }
8482     local($^W)=0;
8483     if ($inst_file
8484         &&
8485         ! CPAN::Version->vgt($latest, $have)
8486        ) {
8487         CPAN->debug("returning uptodate. inst_file[$inst_file] ".
8488                     "latest[$latest] have[$have]") if $CPAN::DEBUG;
8489         return 1;
8490     }
8491     return;
8492 }
8493 #-> sub CPAN::Module::install ;
8494 sub install {
8495     my($self) = @_;
8496     my($doit) = 0;
8497     if ($self->uptodate
8498         &&
8499         not exists $self->{'force_update'}
8500        ) {
8501         $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
8502                                          $self->id,
8503                                          $self->inst_version,
8504                                         ));
8505     } else {
8506         $doit = 1;
8507     }
8508     my $ro = $self->ro;
8509     if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
8510         $CPAN::Frontend->mywarn(qq{
8511 \n\n\n     ***WARNING***
8512      The module $self->{ID} has no active maintainer.\n\n\n
8513 });
8514         $CPAN::Frontend->mysleep(5);
8515     }
8516     $self->rematein('install') if $doit;
8517 }
8518 #-> sub CPAN::Module::clean ;
8519 sub clean  { shift->rematein('clean') }
8520
8521 #-> sub CPAN::Module::inst_file ;
8522 sub inst_file {
8523     my($self) = @_;
8524     my($dir,@packpath);
8525     @packpath = split /::/, $self->{ID};
8526     $packpath[-1] .= ".pm";
8527     if (@packpath == 1 && $packpath[0] eq "readline.pm") {
8528         unshift @packpath, "Term", "ReadLine"; # historical reasons
8529     }
8530     foreach $dir (@INC) {
8531         my $pmfile = File::Spec->catfile($dir,@packpath);
8532         if (-f $pmfile){
8533             return $pmfile;
8534         }
8535     }
8536     return;
8537 }
8538
8539 #-> sub CPAN::Module::xs_file ;
8540 sub xs_file {
8541     my($self) = @_;
8542     my($dir,@packpath);
8543     @packpath = split /::/, $self->{ID};
8544     push @packpath, $packpath[-1];
8545     $packpath[-1] .= "." . $Config::Config{'dlext'};
8546     foreach $dir (@INC) {
8547         my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
8548         if (-f $xsfile){
8549             return $xsfile;
8550         }
8551     }
8552     return;
8553 }
8554
8555 #-> sub CPAN::Module::inst_version ;
8556 sub inst_version {
8557     my($self) = @_;
8558     my $parsefile = $self->inst_file or return;
8559     local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
8560     my $have;
8561
8562     $have = MM->parse_version($parsefile) || "undef";
8563     $have =~ s/^ //; # since the %vd hack these two lines here are needed
8564     $have =~ s/ $//; # trailing whitespace happens all the time
8565
8566     # My thoughts about why %vd processing should happen here
8567
8568     # Alt1 maintain it as string with leading v:
8569     # read index files     do nothing
8570     # compare it           use utility for compare
8571     # print it             do nothing
8572
8573     # Alt2 maintain it as what it is
8574     # read index files     convert
8575     # compare it           use utility because there's still a ">" vs "gt" issue
8576     # print it             use CPAN::Version for print
8577
8578     # Seems cleaner to hold it in memory as a string starting with a "v"
8579
8580     # If the author of this module made a mistake and wrote a quoted
8581     # "v1.13" instead of v1.13, we simply leave it at that with the
8582     # effect that *we* will treat it like a v-tring while the rest of
8583     # perl won't. Seems sensible when we consider that any action we
8584     # could take now would just add complexity.
8585
8586     $have = CPAN::Version->readable($have);
8587
8588     $have =~ s/\s*//g; # stringify to float around floating point issues
8589     $have; # no stringify needed, \s* above matches always
8590 }
8591
8592 package CPAN;
8593 use strict;
8594
8595 1;
8596
8597
8598 __END__
8599
8600 =head1 NAME
8601
8602 CPAN - query, download and build perl modules from CPAN sites
8603
8604 =head1 SYNOPSIS
8605
8606 Interactive mode:
8607
8608   perl -MCPAN -e shell;
8609
8610 Batch mode:
8611
8612   use CPAN;
8613
8614   # Modules:
8615
8616   cpan> install Acme::Meta                       # in the shell
8617
8618   CPAN::Shell->install("Acme::Meta");            # in perl
8619
8620   # Distributions:
8621
8622   cpan> install NWCLARK/Acme-Meta-0.02.tar.gz    # in the shell
8623
8624   CPAN::Shell->
8625     install("NWCLARK/Acme-Meta-0.02.tar.gz");    # in perl
8626
8627   # module objects:
8628
8629   $mo = CPAN::Shell->expandany($mod);
8630   $mo = CPAN::Shell->expand("Module",$mod);      # same thing
8631
8632   # distribution objects:
8633
8634   $do = CPAN::Shell->expand("Module",$mod)->distribution;
8635   $do = CPAN::Shell->expandany($distro);         # same thing
8636   $do = CPAN::Shell->expand("Distribution",
8637                             $distro);            # same thing
8638
8639 =head1 STATUS
8640
8641 This module and its competitor, the CPANPLUS module, are both much
8642 cooler than the other.
8643
8644 =head1 COMPATIBILITY
8645
8646 CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted
8647 newer versions. It is getting more and more difficult to get the
8648 minimal prerequisites working on older perls. It is close to
8649 impossible to get the whole Bundle::CPAN working there. If you're in
8650 the position to have only these old versions, be advised that CPAN is
8651 designed to work fine without the Bundle::CPAN installed.
8652
8653 To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is
8654 compatible with ancient perls and that File::Temp is listed as a
8655 prerequisite but CPAN has reasonable workarounds if it is missing.
8656
8657 =head1 DESCRIPTION
8658
8659 The CPAN module is designed to automate the make and install of perl
8660 modules and extensions. It includes some primitive searching
8661 capabilities and knows how to use Net::FTP or LWP (or some external
8662 download clients) to fetch the raw data from the net.
8663
8664 Modules are fetched from one or more of the mirrored CPAN
8665 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
8666 directory.
8667
8668 The CPAN module also supports the concept of named and versioned
8669 I<bundles> of modules. Bundles simplify the handling of sets of
8670 related modules. See Bundles below.
8671
8672 The package contains a session manager and a cache manager. There is
8673 no status retained between sessions. The session manager keeps track
8674 of what has been fetched, built and installed in the current
8675 session. The cache manager keeps track of the disk space occupied by
8676 the make processes and deletes excess space according to a simple FIFO
8677 mechanism.
8678
8679 All methods provided are accessible in a programmer style and in an
8680 interactive shell style.
8681
8682 =head2 CPAN::shell([$prompt, $command]) Starting Interactive Mode
8683
8684 The interactive mode is entered by running
8685
8686     perl -MCPAN -e shell
8687
8688 which puts you into a readline interface. You will have the most fun if
8689 you install Term::ReadKey and Term::ReadLine to enjoy both history and
8690 command completion.
8691
8692 Once you are on the command line, type 'h' and the rest should be
8693 self-explanatory.
8694
8695 The function call C<shell> takes two optional arguments, one is the
8696 prompt, the second is the default initial command line (the latter
8697 only works if a real ReadLine interface module is installed).
8698
8699 The most common uses of the interactive modes are
8700
8701 =over 2
8702
8703 =item Searching for authors, bundles, distribution files and modules
8704
8705 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
8706 for each of the four categories and another, C<i> for any of the
8707 mentioned four. Each of the four entities is implemented as a class
8708 with slightly differing methods for displaying an object.
8709
8710 Arguments you pass to these commands are either strings exactly matching
8711 the identification string of an object or regular expressions that are
8712 then matched case-insensitively against various attributes of the
8713 objects. The parser recognizes a regular expression only if you
8714 enclose it between two slashes.
8715
8716 The principle is that the number of found objects influences how an
8717 item is displayed. If the search finds one item, the result is
8718 displayed with the rather verbose method C<as_string>, but if we find
8719 more than one, we display each object with the terse method
8720 C<as_glimpse>.
8721
8722 =item make, test, install, clean  modules or distributions
8723
8724 These commands take any number of arguments and investigate what is
8725 necessary to perform the action. If the argument is a distribution
8726 file name (recognized by embedded slashes), it is processed. If it is
8727 a module, CPAN determines the distribution file in which this module
8728 is included and processes that, following any dependencies named in
8729 the module's META.yml or Makefile.PL (this behavior is controlled by
8730 the configuration parameter C<prerequisites_policy>.)
8731
8732 Any C<make> or C<test> are run unconditionally. An
8733
8734   install <distribution_file>
8735
8736 also is run unconditionally. But for
8737
8738   install <module>
8739
8740 CPAN checks if an install is actually needed for it and prints
8741 I<module up to date> in the case that the distribution file containing
8742 the module doesn't need to be updated.
8743
8744 CPAN also keeps track of what it has done within the current session
8745 and doesn't try to build a package a second time regardless if it
8746 succeeded or not. The C<force> pragma may precede another command
8747 (currently: C<make>, C<test>, or C<install>) and executes the
8748 command from scratch and tries to continue in case of some errors.
8749
8750 Example:
8751
8752     cpan> install OpenGL
8753     OpenGL is up to date.
8754     cpan> force install OpenGL
8755     Running make
8756     OpenGL-0.4/
8757     OpenGL-0.4/COPYRIGHT
8758     [...]
8759
8760 The C<notest> pragma may be set to skip the test part in the build
8761 process.
8762
8763 Example:
8764
8765     cpan> notest install Tk
8766
8767 A C<clean> command results in a
8768
8769   make clean
8770
8771 being executed within the distribution file's working directory.
8772
8773 =item get, readme, perldoc, look module or distribution
8774
8775 C<get> downloads a distribution file without further action. C<readme>
8776 displays the README file of the associated distribution. C<Look> gets
8777 and untars (if not yet done) the distribution file, changes to the
8778 appropriate directory and opens a subshell process in that directory.
8779 C<perldoc> displays the pod documentation of the module in html or
8780 plain text format.
8781
8782 =item ls author
8783
8784 =item ls globbing_expression
8785
8786 The first form lists all distribution files in and below an author's
8787 CPAN directory as they are stored in the CHECKUMS files distributed on
8788 CPAN. The listing goes recursive into all subdirectories.
8789
8790 The second form allows to limit or expand the output with shell
8791 globbing as in the following examples:
8792
8793           ls JV/make*
8794           ls GSAR/*make*
8795           ls */*make*
8796
8797 The last example is very slow and outputs extra progress indicators
8798 that break the alignment of the result.
8799
8800 Note that globbing only lists directories explicitly asked for, for
8801 example FOO/* will not list FOO/bar/Acme-Sthg-n.nn.tar.gz. This may be
8802 regarded as a bug and may be changed in future versions.
8803
8804 =item failed
8805
8806 The C<failed> command reports all distributions that failed on one of
8807 C<make>, C<test> or C<install> for some reason in the currently
8808 running shell session.
8809
8810 =item Lockfile
8811
8812 Interactive sessions maintain a lockfile, per default C<~/.cpan/.lock>
8813 (but the directory can be configured via the C<cpan_home> config
8814 variable). The shell is a bit picky if you try to start another CPAN
8815 session. It dies immediately if there is a lockfile and the lock seems
8816 to belong to a running process. In case you want to run a second shell
8817 session, it is probably safest to maintain another directory, say
8818 C<~/.cpan-for-X/> and a C<~/.cpan-for-X/CPAN/MyConfig.pm> that
8819 contains the configuration options. Then you can start the second
8820 shell with
8821
8822   perl -I ~/.cpan-for-X -MCPAN::MyConfig -MCPAN -e shell
8823
8824 =item Signals
8825
8826 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
8827 in the cpan-shell it is intended that you can press C<^C> anytime and
8828 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
8829 to clean up and leave the shell loop. You can emulate the effect of a
8830 SIGTERM by sending two consecutive SIGINTs, which usually means by
8831 pressing C<^C> twice.
8832
8833 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
8834 SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl
8835 Build.PL> subprocess.
8836
8837 =back
8838
8839 =head2 CPAN::Shell
8840
8841 The commands that are available in the shell interface are methods in
8842 the package CPAN::Shell. If you enter the shell command, all your
8843 input is split by the Text::ParseWords::shellwords() routine which
8844 acts like most shells do. The first word is being interpreted as the
8845 method to be called and the rest of the words are treated as arguments
8846 to this method. Continuation lines are supported if a line ends with a
8847 literal backslash.
8848
8849 =head2 autobundle
8850
8851 C<autobundle> writes a bundle file into the
8852 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
8853 a list of all modules that are both available from CPAN and currently
8854 installed within @INC. The name of the bundle file is based on the
8855 current date and a counter.
8856
8857 =head2 hosts
8858
8859 This commands provides a statistical overview over recent download
8860 activities. The data for this is collected in the YAML file
8861 C<FTPstats.yml> in your C<cpan_home> directory. If no YAML module is
8862 configured or YAML not installed, then no stats are provided.
8863
8864 =head2 mkmyconfig
8865
8866 mkmyconfig() writes your own CPAN::MyConfig file into your ~/.cpan/
8867 directory so that you can save your own preferences instead of the
8868 system wide ones.
8869
8870 =head2 recompile
8871
8872 recompile() is a very special command in that it takes no argument and
8873 runs the make/test/install cycle with brute force over all installed
8874 dynamically loadable extensions (aka XS modules) with 'force' in
8875 effect. The primary purpose of this command is to finish a network
8876 installation. Imagine, you have a common source tree for two different
8877 architectures. You decide to do a completely independent fresh
8878 installation. You start on one architecture with the help of a Bundle
8879 file produced earlier. CPAN installs the whole Bundle for you, but
8880 when you try to repeat the job on the second architecture, CPAN
8881 responds with a C<"Foo up to date"> message for all modules. So you
8882 invoke CPAN's recompile on the second architecture and you're done.
8883
8884 Another popular use for C<recompile> is to act as a rescue in case your
8885 perl breaks binary compatibility. If one of the modules that CPAN uses
8886 is in turn depending on binary compatibility (so you cannot run CPAN
8887 commands), then you should try the CPAN::Nox module for recovery.
8888
8889 =head2 report Bundle|Distribution|Module
8890
8891 The C<report> command temporarily turns on the C<test_report> config
8892 variable, then runs the C<force test> command with the given
8893 arguments. The C<force> pragma is used to re-run the tests and repeat
8894 every step that might have failed before.
8895
8896 =head2 upgrade [Module|/Regex/]...
8897
8898 The C<upgrade> command first runs an C<r> command with the given
8899 arguments and then installs the newest versions of all modules that
8900 were listed by that.
8901
8902 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
8903
8904 Although it may be considered internal, the class hierarchy does matter
8905 for both users and programmer. CPAN.pm deals with above mentioned four
8906 classes, and all those classes share a set of methods. A classical
8907 single polymorphism is in effect. A metaclass object registers all
8908 objects of all kinds and indexes them with a string. The strings
8909 referencing objects have a separated namespace (well, not completely
8910 separated):
8911
8912          Namespace                         Class
8913
8914    words containing a "/" (slash)      Distribution
8915     words starting with Bundle::          Bundle
8916           everything else            Module or Author
8917
8918 Modules know their associated Distribution objects. They always refer
8919 to the most recent official release. Developers may mark their releases
8920 as unstable development versions (by inserting an underbar into the
8921 module version number which will also be reflected in the distribution
8922 name when you run 'make dist'), so the really hottest and newest
8923 distribution is not always the default.  If a module Foo circulates
8924 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
8925 way to install version 1.23 by saying
8926
8927     install Foo
8928
8929 This would install the complete distribution file (say
8930 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
8931 like to install version 1.23_90, you need to know where the
8932 distribution file resides on CPAN relative to the authors/id/
8933 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
8934 so you would have to say
8935
8936     install BAR/Foo-1.23_90.tar.gz
8937
8938 The first example will be driven by an object of the class
8939 CPAN::Module, the second by an object of class CPAN::Distribution.
8940
8941 =head2 Integrating local directories
8942
8943 Distribution objects are normally distributions from the CPAN, but
8944 there is a slightly degenerate case for Distribution objects, too,
8945 normally only needed by developers. If a distribution object ends with
8946 a dot or is a dot by itself, then it represents a local directory and
8947 all actions such as C<make>, C<test>, and C<install> are applied
8948 directly to that directory. This gives the command C<cpan .> an
8949 interesting touch: while the normal mantra of installing a CPAN module
8950 without CPAN.pm is one of
8951
8952     perl Makefile.PL                 perl Build.PL
8953            ( go and get prerequisites )
8954     make                             ./Build
8955     make test                        ./Build test
8956     make install                     ./Build install
8957
8958 the command C<cpan .> does all of this at once. It figures out which
8959 of the two mantras is appropriate, fetches and installs all
8960 prerequisites, cares for them recursively and finally finishes the
8961 installation of the module in the current directory, be it a CPAN
8962 module or not.
8963
8964 =head1 PROGRAMMER'S INTERFACE
8965
8966 If you do not enter the shell, the available shell commands are both
8967 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
8968 functions in the calling package (C<install(...)>).  Before calling low-level
8969 commands it makes sense to initialize components of CPAN you need, e.g.:
8970
8971   CPAN::HandleConfig->load;
8972   CPAN::Shell::setup_output;
8973   CPAN::Index->reload;
8974
8975 High-level commands do such initializations automatically.
8976
8977 There's currently only one class that has a stable interface -
8978 CPAN::Shell. All commands that are available in the CPAN shell are
8979 methods of the class CPAN::Shell. Each of the commands that produce
8980 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
8981 the IDs of all modules within the list.
8982
8983 =over 2
8984
8985 =item expand($type,@things)
8986
8987 The IDs of all objects available within a program are strings that can
8988 be expanded to the corresponding real objects with the
8989 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
8990 list of CPAN::Module objects according to the C<@things> arguments
8991 given. In scalar context it only returns the first element of the
8992 list.
8993
8994 =item expandany(@things)
8995
8996 Like expand, but returns objects of the appropriate type, i.e.
8997 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
8998 CPAN::Distribution objects for distributions. Note: it does not expand
8999 to CPAN::Author objects.
9000
9001 =item Programming Examples
9002
9003 This enables the programmer to do operations that combine
9004 functionalities that are available in the shell.
9005
9006     # install everything that is outdated on my disk:
9007     perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
9008
9009     # install my favorite programs if necessary:
9010     for $mod (qw(Net::FTP Digest::SHA Data::Dumper)){
9011         CPAN::Shell->install($mod);
9012     }
9013
9014     # list all modules on my disk that have no VERSION number
9015     for $mod (CPAN::Shell->expand("Module","/./")){
9016         next unless $mod->inst_file;
9017         # MakeMaker convention for undefined $VERSION:
9018         next unless $mod->inst_version eq "undef";
9019         print "No VERSION in ", $mod->id, "\n";
9020     }
9021
9022     # find out which distribution on CPAN contains a module:
9023     print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
9024
9025 Or if you want to write a cronjob to watch The CPAN, you could list
9026 all modules that need updating. First a quick and dirty way:
9027
9028     perl -e 'use CPAN; CPAN::Shell->r;'
9029
9030 If you don't want to get any output in the case that all modules are
9031 up to date, you can parse the output of above command for the regular
9032 expression //modules are up to date// and decide to mail the output
9033 only if it doesn't match. Ick?
9034
9035 If you prefer to do it more in a programmer style in one single
9036 process, maybe something like this suits you better:
9037
9038   # list all modules on my disk that have newer versions on CPAN
9039   for $mod (CPAN::Shell->expand("Module","/./")){
9040     next unless $mod->inst_file;
9041     next if $mod->uptodate;
9042     printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
9043         $mod->id, $mod->inst_version, $mod->cpan_version;
9044   }
9045
9046 If that gives you too much output every day, you maybe only want to
9047 watch for three modules. You can write
9048
9049   for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
9050
9051 as the first line instead. Or you can combine some of the above
9052 tricks:
9053
9054   # watch only for a new mod_perl module
9055   $mod = CPAN::Shell->expand("Module","mod_perl");
9056   exit if $mod->uptodate;
9057   # new mod_perl arrived, let me know all update recommendations
9058   CPAN::Shell->r;
9059
9060 =back
9061
9062 =head2 Methods in the other Classes
9063
9064 The programming interface for the classes CPAN::Module,
9065 CPAN::Distribution, CPAN::Bundle, and CPAN::Author is still considered
9066 beta and partially even alpha. In the following paragraphs only those
9067 methods are documented that have proven useful over a longer time and
9068 thus are unlikely to change.
9069
9070 =over 4
9071
9072 =item CPAN::Author::as_glimpse()
9073
9074 Returns a one-line description of the author
9075
9076 =item CPAN::Author::as_string()
9077
9078 Returns a multi-line description of the author
9079
9080 =item CPAN::Author::email()
9081
9082 Returns the author's email address
9083
9084 =item CPAN::Author::fullname()
9085
9086 Returns the author's name
9087
9088 =item CPAN::Author::name()
9089
9090 An alias for fullname
9091
9092 =item CPAN::Bundle::as_glimpse()
9093
9094 Returns a one-line description of the bundle
9095
9096 =item CPAN::Bundle::as_string()
9097
9098 Returns a multi-line description of the bundle
9099
9100 =item CPAN::Bundle::clean()
9101
9102 Recursively runs the C<clean> method on all items contained in the bundle.
9103
9104 =item CPAN::Bundle::contains()
9105
9106 Returns a list of objects' IDs contained in a bundle. The associated
9107 objects may be bundles, modules or distributions.
9108
9109 =item CPAN::Bundle::force($method,@args)
9110
9111 Forces CPAN to perform a task that normally would have failed. Force
9112 takes as arguments a method name to be called and any number of
9113 additional arguments that should be passed to the called method. The
9114 internals of the object get the needed changes so that CPAN.pm does
9115 not refuse to take the action. The C<force> is passed recursively to
9116 all contained objects.
9117
9118 =item CPAN::Bundle::get()
9119
9120 Recursively runs the C<get> method on all items contained in the bundle
9121
9122 =item CPAN::Bundle::inst_file()
9123
9124 Returns the highest installed version of the bundle in either @INC or
9125 C<$CPAN::Config->{cpan_home}>. Note that this is different from
9126 CPAN::Module::inst_file.
9127
9128 =item CPAN::Bundle::inst_version()
9129
9130 Like CPAN::Bundle::inst_file, but returns the $VERSION
9131
9132 =item CPAN::Bundle::uptodate()
9133
9134 Returns 1 if the bundle itself and all its members are uptodate.
9135
9136 =item CPAN::Bundle::install()
9137
9138 Recursively runs the C<install> method on all items contained in the bundle
9139
9140 =item CPAN::Bundle::make()
9141
9142 Recursively runs the C<make> method on all items contained in the bundle
9143
9144 =item CPAN::Bundle::readme()
9145
9146 Recursively runs the C<readme> method on all items contained in the bundle
9147
9148 =item CPAN::Bundle::test()
9149
9150 Recursively runs the C<test> method on all items contained in the bundle
9151
9152 =item CPAN::Distribution::as_glimpse()
9153
9154 Returns a one-line description of the distribution
9155
9156 =item CPAN::Distribution::as_string()
9157
9158 Returns a multi-line description of the distribution
9159
9160 =item CPAN::Distribution::author
9161
9162 Returns the CPAN::Author object of the maintainer who uploaded this
9163 distribution
9164
9165 =item CPAN::Distribution::clean()
9166
9167 Changes to the directory where the distribution has been unpacked and
9168 runs C<make clean> there.
9169
9170 =item CPAN::Distribution::containsmods()
9171
9172 Returns a list of IDs of modules contained in a distribution file.
9173 Only works for distributions listed in the 02packages.details.txt.gz
9174 file. This typically means that only the most recent version of a
9175 distribution is covered.
9176
9177 =item CPAN::Distribution::cvs_import()
9178
9179 Changes to the directory where the distribution has been unpacked and
9180 runs something like
9181
9182     cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
9183
9184 there.
9185
9186 =item CPAN::Distribution::dir()
9187
9188 Returns the directory into which this distribution has been unpacked.
9189
9190 =item CPAN::Distribution::force($method,@args)
9191
9192 Forces CPAN to perform a task that normally would have failed. Force
9193 takes as arguments a method name to be called and any number of
9194 additional arguments that should be passed to the called method. The
9195 internals of the object get the needed changes so that CPAN.pm does
9196 not refuse to take the action.
9197
9198 =item CPAN::Distribution::get()
9199
9200 Downloads the distribution from CPAN and unpacks it. Does nothing if
9201 the distribution has already been downloaded and unpacked within the
9202 current session.
9203
9204 =item CPAN::Distribution::install()
9205
9206 Changes to the directory where the distribution has been unpacked and
9207 runs the external command C<make install> there. If C<make> has not
9208 yet been run, it will be run first. A C<make test> will be issued in
9209 any case and if this fails, the install will be canceled. The
9210 cancellation can be avoided by letting C<force> run the C<install> for
9211 you.
9212
9213 This install method has only the power to install the distribution if
9214 there are no dependencies in the way. To install an object and all of
9215 its dependencies, use CPAN::Shell->install.
9216
9217 Note that install() gives no meaningful return value. See uptodate().
9218
9219 =item CPAN::Distribution::isa_perl()
9220
9221 Returns 1 if this distribution file seems to be a perl distribution.
9222 Normally this is derived from the file name only, but the index from
9223 CPAN can contain a hint to achieve a return value of true for other
9224 filenames too.
9225
9226 =item CPAN::Distribution::look()
9227
9228 Changes to the directory where the distribution has been unpacked and
9229 opens a subshell there. Exiting the subshell returns.
9230
9231 =item CPAN::Distribution::make()
9232
9233 First runs the C<get> method to make sure the distribution is
9234 downloaded and unpacked. Changes to the directory where the
9235 distribution has been unpacked and runs the external commands C<perl
9236 Makefile.PL> or C<perl Build.PL> and C<make> there.
9237
9238 =item CPAN::Distribution::perldoc()
9239
9240 Downloads the pod documentation of the file associated with a
9241 distribution (in html format) and runs it through the external
9242 command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
9243 isn't available, it converts it to plain text with external
9244 command html2text and runs it through the pager specified
9245 in C<$CPAN::Config->{pager}>
9246
9247 =item CPAN::Distribution::prefs()
9248
9249 Returns the hash reference from the first matching YAML file that the
9250 user has deposited in the C<prefs_dir/> directory. The first
9251 succeeding match wins. The files in the C<prefs_dir/> are processed
9252 alphabetically and the canonical distroname (e.g.
9253 AUTHOR/Foo-Bar-3.14.tar.gz) is matched against the regular expressions
9254 stored in the $root->{match}{distribution} attribute value.
9255 Additionally all module names contained in a distribution are matched
9256 agains the regular expressions in the $root->{match}{module} attribute
9257 value. The two match values are ANDed together. Each of the two
9258 attributes are optional.
9259
9260 =item CPAN::Distribution::prereq_pm()
9261
9262 Returns the hash reference that has been announced by a distribution
9263 as the merge of the C<requires> element and the C<build_requires>
9264 element of the META.yml or the C<PREREQ_PM> hash in the
9265 C<Makefile.PL>. Note: works only after an attempt has been made to
9266 C<make> the distribution. Returns undef otherwise.
9267
9268 =item CPAN::Distribution::readme()
9269
9270 Downloads the README file associated with a distribution and runs it
9271 through the pager specified in C<$CPAN::Config->{pager}>.
9272
9273 =item CPAN::Distribution::read_yaml()
9274
9275 Returns the content of the META.yml of this distro as a hashref. Note:
9276 works only after an attempt has been made to C<make> the distribution.
9277 Returns undef otherwise. Also returns undef if the content of META.yml
9278 is dynamic.
9279
9280 =item CPAN::Distribution::test()
9281
9282 Changes to the directory where the distribution has been unpacked and
9283 runs C<make test> there.
9284
9285 =item CPAN::Distribution::uptodate()
9286
9287 Returns 1 if all the modules contained in the distribution are
9288 uptodate. Relies on containsmods.
9289
9290 =item CPAN::Index::force_reload()
9291
9292 Forces a reload of all indices.
9293
9294 =item CPAN::Index::reload()
9295
9296 Reloads all indices if they have not been read for more than
9297 C<$CPAN::Config->{index_expire}> days.
9298
9299 =item CPAN::InfoObj::dump()
9300
9301 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
9302 inherit this method. It prints the data structure associated with an
9303 object. Useful for debugging. Note: the data structure is considered
9304 internal and thus subject to change without notice.
9305
9306 =item CPAN::Module::as_glimpse()
9307
9308 Returns a one-line description of the module in four columns: The
9309 first column contains the word C<Module>, the second column consists
9310 of one character: an equals sign if this module is already installed
9311 and uptodate, a less-than sign if this module is installed but can be
9312 upgraded, and a space if the module is not installed. The third column
9313 is the name of the module and the fourth column gives maintainer or
9314 distribution information.
9315
9316 =item CPAN::Module::as_string()
9317
9318 Returns a multi-line description of the module
9319
9320 =item CPAN::Module::clean()
9321
9322 Runs a clean on the distribution associated with this module.
9323
9324 =item CPAN::Module::cpan_file()
9325
9326 Returns the filename on CPAN that is associated with the module.
9327
9328 =item CPAN::Module::cpan_version()
9329
9330 Returns the latest version of this module available on CPAN.
9331
9332 =item CPAN::Module::cvs_import()
9333
9334 Runs a cvs_import on the distribution associated with this module.
9335
9336 =item CPAN::Module::description()
9337
9338 Returns a 44 character description of this module. Only available for
9339 modules listed in The Module List (CPAN/modules/00modlist.long.html
9340 or 00modlist.long.txt.gz)
9341
9342 =item CPAN::Module::distribution()
9343
9344 Returns the CPAN::Distribution object that contains the current
9345 version of this module.
9346
9347 =item CPAN::Module::dslip_status()
9348
9349 Returns a hash reference. The keys of the hash are the letters C<D>,
9350 C<S>, C<L>, C<I>, and <P>, for development status, support level,
9351 language, interface and public licence respectively. The data for the
9352 DSLIP status are collected by pause.perl.org when authors register
9353 their namespaces. The values of the 5 hash elements are one-character
9354 words whose meaning is described in the table below. There are also 5
9355 hash elements C<DV>, C<SV>, C<LV>, C<IV>, and <PV> that carry a more
9356 verbose value of the 5 status variables.
9357
9358 Where the 'DSLIP' characters have the following meanings:
9359
9360   D - Development Stage  (Note: *NO IMPLIED TIMESCALES*):
9361     i   - Idea, listed to gain consensus or as a placeholder
9362     c   - under construction but pre-alpha (not yet released)
9363     a/b - Alpha/Beta testing
9364     R   - Released
9365     M   - Mature (no rigorous definition)
9366     S   - Standard, supplied with Perl 5
9367
9368   S - Support Level:
9369     m   - Mailing-list
9370     d   - Developer
9371     u   - Usenet newsgroup comp.lang.perl.modules
9372     n   - None known, try comp.lang.perl.modules
9373     a   - abandoned; volunteers welcome to take over maintainance
9374
9375   L - Language Used:
9376     p   - Perl-only, no compiler needed, should be platform independent
9377     c   - C and perl, a C compiler will be needed
9378     h   - Hybrid, written in perl with optional C code, no compiler needed
9379     +   - C++ and perl, a C++ compiler will be needed
9380     o   - perl and another language other than C or C++
9381
9382   I - Interface Style
9383     f   - plain Functions, no references used
9384     h   - hybrid, object and function interfaces available
9385     n   - no interface at all (huh?)
9386     r   - some use of unblessed References or ties
9387     O   - Object oriented using blessed references and/or inheritance
9388
9389   P - Public License
9390     p   - Standard-Perl: user may choose between GPL and Artistic
9391     g   - GPL: GNU General Public License
9392     l   - LGPL: "GNU Lesser General Public License" (previously known as
9393           "GNU Library General Public License")
9394     b   - BSD: The BSD License
9395     a   - Artistic license alone
9396     o   - open source: appoved by www.opensource.org
9397     d   - allows distribution without restrictions
9398     r   - restricted distribtion
9399     n   - no license at all
9400
9401 =item CPAN::Module::force($method,@args)
9402
9403 Forces CPAN to perform a task that normally would have failed. Force
9404 takes as arguments a method name to be called and any number of
9405 additional arguments that should be passed to the called method. The
9406 internals of the object get the needed changes so that CPAN.pm does
9407 not refuse to take the action.
9408
9409 =item CPAN::Module::get()
9410
9411 Runs a get on the distribution associated with this module.
9412
9413 =item CPAN::Module::inst_file()
9414
9415 Returns the filename of the module found in @INC. The first file found
9416 is reported just like perl itself stops searching @INC when it finds a
9417 module.
9418
9419 =item CPAN::Module::inst_version()
9420
9421 Returns the version number of the module in readable format.
9422
9423 =item CPAN::Module::install()
9424
9425 Runs an C<install> on the distribution associated with this module.
9426
9427 =item CPAN::Module::look()
9428
9429 Changes to the directory where the distribution associated with this
9430 module has been unpacked and opens a subshell there. Exiting the
9431 subshell returns.
9432
9433 =item CPAN::Module::make()
9434
9435 Runs a C<make> on the distribution associated with this module.
9436
9437 =item CPAN::Module::manpage_headline()
9438
9439 If module is installed, peeks into the module's manpage, reads the
9440 headline and returns it. Moreover, if the module has been downloaded
9441 within this session, does the equivalent on the downloaded module even
9442 if it is not installed.
9443
9444 =item CPAN::Module::perldoc()
9445
9446 Runs a C<perldoc> on this module.
9447
9448 =item CPAN::Module::readme()
9449
9450 Runs a C<readme> on the distribution associated with this module.
9451
9452 =item CPAN::Module::test()
9453
9454 Runs a C<test> on the distribution associated with this module.
9455
9456 =item CPAN::Module::uptodate()
9457
9458 Returns 1 if the module is installed and up-to-date.
9459
9460 =item CPAN::Module::userid()
9461
9462 Returns the author's ID of the module.
9463
9464 =back
9465
9466 =head2 Cache Manager
9467
9468 Currently the cache manager only keeps track of the build directory
9469 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
9470 deletes complete directories below C<build_dir> as soon as the size of
9471 all directories there gets bigger than $CPAN::Config->{build_cache}
9472 (in MB). The contents of this cache may be used for later
9473 re-installations that you intend to do manually, but will never be
9474 trusted by CPAN itself. This is due to the fact that the user might
9475 use these directories for building modules on different architectures.
9476
9477 There is another directory ($CPAN::Config->{keep_source_where}) where
9478 the original distribution files are kept. This directory is not
9479 covered by the cache manager and must be controlled by the user. If
9480 you choose to have the same directory as build_dir and as
9481 keep_source_where directory, then your sources will be deleted with
9482 the same fifo mechanism.
9483
9484 =head2 Bundles
9485
9486 A bundle is just a perl module in the namespace Bundle:: that does not
9487 define any functions or methods. It usually only contains documentation.
9488
9489 It starts like a perl module with a package declaration and a $VERSION
9490 variable. After that the pod section looks like any other pod with the
9491 only difference being that I<one special pod section> exists starting with
9492 (verbatim):
9493
9494         =head1 CONTENTS
9495
9496 In this pod section each line obeys the format
9497
9498         Module_Name [Version_String] [- optional text]
9499
9500 The only required part is the first field, the name of a module
9501 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
9502 of the line is optional. The comment part is delimited by a dash just
9503 as in the man page header.
9504
9505 The distribution of a bundle should follow the same convention as
9506 other distributions.
9507
9508 Bundles are treated specially in the CPAN package. If you say 'install
9509 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
9510 the modules in the CONTENTS section of the pod. You can install your
9511 own Bundles locally by placing a conformant Bundle file somewhere into
9512 your @INC path. The autobundle() command which is available in the
9513 shell interface does that for you by including all currently installed
9514 modules in a snapshot bundle file.
9515
9516 =head1 PREREQUISITES
9517
9518 If you have a local mirror of CPAN and can access all files with
9519 "file:" URLs, then you only need a perl better than perl5.003 to run
9520 this module. Otherwise Net::FTP is strongly recommended. LWP may be
9521 required for non-UNIX systems or if your nearest CPAN site is
9522 associated with a URL that is not C<ftp:>.
9523
9524 If you have neither Net::FTP nor LWP, there is a fallback mechanism
9525 implemented for an external ftp command or for an external lynx
9526 command.
9527
9528 =head1 UTILITIES
9529
9530 =head2 Finding packages and VERSION
9531
9532 This module presumes that all packages on CPAN
9533
9534 =over 2
9535
9536 =item *
9537
9538 declare their $VERSION variable in an easy to parse manner. This
9539 prerequisite can hardly be relaxed because it consumes far too much
9540 memory to load all packages into the running program just to determine
9541 the $VERSION variable. Currently all programs that are dealing with
9542 version use something like this
9543
9544     perl -MExtUtils::MakeMaker -le \
9545         'print MM->parse_version(shift)' filename
9546
9547 If you are author of a package and wonder if your $VERSION can be
9548 parsed, please try the above method.
9549
9550 =item *
9551
9552 come as compressed or gzipped tarfiles or as zip files and contain a
9553 C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
9554 without much enthusiasm).
9555
9556 =back
9557
9558 =head2 Debugging
9559
9560 The debugging of this module is a bit complex, because we have
9561 interferences of the software producing the indices on CPAN, of the
9562 mirroring process on CPAN, of packaging, of configuration, of
9563 synchronicity, and of bugs within CPAN.pm.
9564
9565 For debugging the code of CPAN.pm itself in interactive mode some more
9566 or less useful debugging aid can be turned on for most packages within
9567 CPAN.pm with one of
9568
9569 =over 2
9570
9571 =item o debug package...
9572
9573 sets debug mode for packages.
9574
9575 =item o debug -package...
9576
9577 unsets debug mode for packages.
9578
9579 =item o debug all
9580
9581 turns debugging on for all packages.
9582
9583 =item o debug number
9584
9585 =back
9586
9587 which sets the debugging packages directly. Note that C<o debug 0>
9588 turns debugging off.
9589
9590 What seems quite a successful strategy is the combination of C<reload
9591 cpan> and the debugging switches. Add a new debug statement while
9592 running in the shell and then issue a C<reload cpan> and see the new
9593 debugging messages immediately without losing the current context.
9594
9595 C<o debug> without an argument lists the valid package names and the
9596 current set of packages in debugging mode. C<o debug> has built-in
9597 completion support.
9598
9599 For debugging of CPAN data there is the C<dump> command which takes
9600 the same arguments as make/test/install and outputs each object's
9601 Data::Dumper dump. If an argument looks like a perl variable and
9602 contains one of C<$>, C<@> or C<%>, it is eval()ed and fed to
9603 Data::Dumper directly.
9604
9605 =head2 Floppy, Zip, Offline Mode
9606
9607 CPAN.pm works nicely without network too. If you maintain machines
9608 that are not networked at all, you should consider working with file:
9609 URLs. Of course, you have to collect your modules somewhere first. So
9610 you might use CPAN.pm to put together all you need on a networked
9611 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
9612 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
9613 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
9614 with this floppy. See also below the paragraph about CD-ROM support.
9615
9616 =head2 Basic Utilities for Programmers
9617
9618 =over 2
9619
9620 =item has_inst($module)
9621
9622 Returns true if the module is installed. See the source for details.
9623
9624 =item has_usable($module)
9625
9626 Returns true if the module is installed and several and is in a usable
9627 state. Only useful for a handful of modules that are used internally.
9628 See the source for details.
9629
9630 =item instance($module)
9631
9632 The constructor for all the singletons used to represent modules,
9633 distributions, authors and bundles. If the object already exists, this
9634 method returns the object, otherwise it calls the constructor.
9635
9636 =back
9637
9638 =head1 CONFIGURATION
9639
9640 When the CPAN module is used for the first time, a configuration
9641 dialog tries to determine a couple of site specific options. The
9642 result of the dialog is stored in a hash reference C< $CPAN::Config >
9643 in a file CPAN/Config.pm.
9644
9645 The default values defined in the CPAN/Config.pm file can be
9646 overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
9647 best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
9648 added to the search path of the CPAN module before the use() or
9649 require() statements. The mkmyconfig command writes this file for you.
9650
9651 The C<o conf> command has various bells and whistles:
9652
9653 =over
9654
9655 =item completion support
9656
9657 If you have a ReadLine module installed, you can hit TAB at any point
9658 of the commandline and C<o conf> will offer you completion for the
9659 built-in subcommands and/or config variable names.
9660
9661 =item displaying some help: o conf help
9662
9663 Displays a short help
9664
9665 =item displaying current values: o conf [KEY]
9666
9667 Displays the current value(s) for this config variable. Without KEY
9668 displays all subcommands and config variables.
9669
9670 Example:
9671
9672   o conf shell
9673
9674 =item changing of scalar values: o conf KEY VALUE
9675
9676 Sets the config variable KEY to VALUE. The empty string can be
9677 specified as usual in shells, with C<''> or C<"">
9678
9679 Example:
9680
9681   o conf wget /usr/bin/wget
9682
9683 =item changing of list values: o conf KEY SHIFT|UNSHIFT|PUSH|POP|SPLICE|LIST
9684
9685 If a config variable name ends with C<list>, it is a list. C<o conf
9686 KEY shift> removes the first element of the list, C<o conf KEY pop>
9687 removes the last element of the list. C<o conf KEYS unshift LIST>
9688 prepends a list of values to the list, C<o conf KEYS push LIST>
9689 appends a list of valued to the list.
9690
9691 Likewise, C<o conf KEY splice LIST> passes the LIST to the according
9692 splice command.
9693
9694 Finally, any other list of arguments is taken as a new list value for
9695 the KEY variable discarding the previous value.
9696
9697 Examples:
9698
9699   o conf urllist unshift http://cpan.dev.local/CPAN
9700   o conf urllist splice 3 1
9701   o conf urllist http://cpan1.local http://cpan2.local ftp://ftp.perl.org
9702
9703 =item interactive editing: o conf init [MATCH|LIST]
9704
9705 Runs an interactive configuration dialog for matching variables.
9706 Without argument runs the dialog over all supported config variables.
9707 To specify a MATCH the argument must be enclosed by slashes.
9708
9709 Examples:
9710
9711   o conf init ftp_passive ftp_proxy
9712   o conf init /color/
9713
9714 =item reverting to saved: o conf defaults
9715
9716 Reverts all config variables to the state in the saved config file.
9717
9718 =item saving the config: o conf commit
9719
9720 Saves all config variables to the current config file (CPAN/Config.pm
9721 or CPAN/MyConfig.pm that was loaded at start).
9722
9723 =back
9724
9725 The configuration dialog can be started any time later again by
9726 issuing the command C< o conf init > in the CPAN shell. A subset of
9727 the configuration dialog can be run by issuing C<o conf init WORD>
9728 where WORD is any valid config variable or a regular expression.
9729
9730 =head2 Config Variables
9731
9732 Currently the following keys in the hash reference $CPAN::Config are
9733 defined:
9734
9735   build_cache        size of cache for directories to build modules
9736   build_dir          locally accessible directory to build modules
9737   build_dir_reuse    boolean if distros in build_dir are persistent
9738   build_requires_install_policy
9739                      to install or not to install: when a module is
9740                      only needed for building. yes|no|ask/yes|ask/no
9741   bzip2              path to external prg
9742   cache_metadata     use serializer to cache metadata
9743   commands_quote     prefered character to use for quoting external
9744                      commands when running them. Defaults to double
9745                      quote on Windows, single tick everywhere else;
9746                      can be set to space to disable quoting
9747   check_sigs         if signatures should be verified
9748   colorize_output    boolean if Term::ANSIColor should colorize output
9749   colorize_print     Term::ANSIColor attributes for normal output
9750   colorize_warn      Term::ANSIColor attributes for warnings
9751   commandnumber_in_prompt
9752                      boolean if you want to see current command number
9753   cpan_home          local directory reserved for this package
9754   curl               path to external prg
9755   dontload_hash      DEPRECATED
9756   dontload_list      arrayref: modules in the list will not be
9757                      loaded by the CPAN::has_inst() routine
9758   ftp                path to external prg
9759   ftp_passive        if set, the envariable FTP_PASSIVE is set for downloads
9760   ftp_proxy          proxy host for ftp requests
9761   getcwd             see below
9762   gpg                path to external prg
9763   gzip               location of external program gzip
9764   histfile           file to maintain history between sessions
9765   histsize           maximum number of lines to keep in histfile
9766   http_proxy         proxy host for http requests
9767   inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
9768                      after this many seconds inactivity. Set to 0 to
9769                      never break.
9770   index_expire       after this many days refetch index files
9771   inhibit_startup_message
9772                      if true, does not print the startup message
9773   keep_source_where  directory in which to keep the source (if we do)
9774   lynx               path to external prg
9775   make               location of external make program
9776   make_arg           arguments that should always be passed to 'make'
9777   make_install_make_command
9778                      the make command for running 'make install', for
9779                      example 'sudo make'
9780   make_install_arg   same as make_arg for 'make install'
9781   makepl_arg         arguments passed to 'perl Makefile.PL'
9782   mbuild_arg         arguments passed to './Build'
9783   mbuild_install_arg arguments passed to './Build install'
9784   mbuild_install_build_command
9785                      command to use instead of './Build' when we are
9786                      in the install stage, for example 'sudo ./Build'
9787   mbuildpl_arg       arguments passed to 'perl Build.PL'
9788   ncftp              path to external prg
9789   ncftpget           path to external prg
9790   no_proxy           don't proxy to these hosts/domains (comma separated list)
9791   pager              location of external program more (or any pager)
9792   password           your password if you CPAN server wants one
9793   patch              path to external prg
9794   prefer_installer   legal values are MB and EUMM: if a module comes
9795                      with both a Makefile.PL and a Build.PL, use the
9796                      former (EUMM) or the latter (MB); if the module
9797                      comes with only one of the two, that one will be
9798                      used in any case
9799   prerequisites_policy
9800                      what to do if you are missing module prerequisites
9801                      ('follow' automatically, 'ask' me, or 'ignore')
9802   prefs_dir          local directory to store per-distro build options
9803   proxy_user         username for accessing an authenticating proxy
9804   proxy_pass         password for accessing an authenticating proxy
9805   randomize_urllist  add some randomness to the sequence of the urllist
9806   scan_cache         controls scanning of cache ('atstart' or 'never')
9807   shell              your favorite shell
9808   show_upload_date   boolean if commands should try to determine upload date
9809   tar                location of external program tar
9810   term_is_latin      if true internal UTF-8 is translated to ISO-8859-1
9811                      (and nonsense for characters outside latin range)
9812   term_ornaments     boolean to turn ReadLine ornamenting on/off
9813   test_report        email test reports (if CPAN::Reporter is installed)
9814   unzip              location of external program unzip
9815   urllist            arrayref to nearby CPAN sites (or equivalent locations)
9816   username           your username if you CPAN server wants one
9817   wait_list          arrayref to a wait server to try (See CPAN::WAIT)
9818   wget               path to external prg
9819   yaml_module        which module to use to read/write YAML files
9820
9821 You can set and query each of these options interactively in the cpan
9822 shell with the command set defined within the C<o conf> command:
9823
9824 =over 2
9825
9826 =item C<o conf E<lt>scalar optionE<gt>>
9827
9828 prints the current value of the I<scalar option>
9829
9830 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
9831
9832 Sets the value of the I<scalar option> to I<value>
9833
9834 =item C<o conf E<lt>list optionE<gt>>
9835
9836 prints the current value of the I<list option> in MakeMaker's
9837 neatvalue format.
9838
9839 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
9840
9841 shifts or pops the array in the I<list option> variable
9842
9843 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
9844
9845 works like the corresponding perl commands.
9846
9847 =back
9848
9849 =head2 CPAN::anycwd($path): Note on config variable getcwd
9850
9851 CPAN.pm changes the current working directory often and needs to
9852 determine its own current working directory. Per default it uses
9853 Cwd::cwd but if this doesn't work on your system for some reason,
9854 alternatives can be configured according to the following table:
9855
9856 =over 2
9857
9858 =item cwd
9859
9860 Calls Cwd::cwd
9861
9862 =item getcwd
9863
9864 Calls Cwd::getcwd
9865
9866 =item fastcwd
9867
9868 Calls Cwd::fastcwd
9869
9870 =item backtickcwd
9871
9872 Calls the external command cwd.
9873
9874 =back
9875
9876 =head2 Note on the format of the urllist parameter
9877
9878 urllist parameters are URLs according to RFC 1738. We do a little
9879 guessing if your URL is not compliant, but if you have problems with
9880 C<file> URLs, please try the correct format. Either:
9881
9882     file://localhost/whatever/ftp/pub/CPAN/
9883
9884 or
9885
9886     file:///home/ftp/pub/CPAN/
9887
9888 =head2 urllist parameter has CD-ROM support
9889
9890 The C<urllist> parameter of the configuration table contains a list of
9891 URLs that are to be used for downloading. If the list contains any
9892 C<file> URLs, CPAN always tries to get files from there first. This
9893 feature is disabled for index files. So the recommendation for the
9894 owner of a CD-ROM with CPAN contents is: include your local, possibly
9895 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
9896
9897   o conf urllist push file://localhost/CDROM/CPAN
9898
9899 CPAN.pm will then fetch the index files from one of the CPAN sites
9900 that come at the beginning of urllist. It will later check for each
9901 module if there is a local copy of the most recent version.
9902
9903 Another peculiarity of urllist is that the site that we could
9904 successfully fetch the last file from automatically gets a preference
9905 token and is tried as the first site for the next request. So if you
9906 add a new site at runtime it may happen that the previously preferred
9907 site will be tried another time. This means that if you want to disallow
9908 a site for the next transfer, it must be explicitly removed from
9909 urllist.
9910
9911 =head2 Maintaining the urllist parameter
9912
9913 If you have YAML.pm (or some other YAML module configured in
9914 C<yaml_module>) installed, CPAN.pm collects a few statistical data
9915 about recent downloads. You can view the statistics with the C<hosts>
9916 command or inspect them directly by looking into the C<FTPstats.yml>
9917 file in your C<cpan_home> directory.
9918
9919 To get some interesting statistics it is recommended to set the
9920 C<randomize_urllist> parameter that introduces some amount of
9921 randomness into the URL selection.
9922
9923 =head2 prefs_dir for avoiding interactive questions (ALPHA)
9924
9925 (B<Note:> This feature has been introduced in CPAN.pm 1.8854 and is
9926 still considered experimental and may still be changed)
9927
9928 The files in the directory specified in C<prefs_dir> are YAML files
9929 that specify how CPAN.pm shall treat distributions that deviate from
9930 the normal non-interactive model of building and installing CPAN
9931 modules.
9932
9933 Some modules try to get some data from the user interactively thus
9934 disturbing the installation of large bundles like Phalanx100 or
9935 modules like Plagger.
9936
9937 CPAN.pm can use YAML files to either pass additional arguments to one
9938 of the four commands, set environment variables or instantiate an
9939 Expect object that reads from the console and enters answers on your
9940 behalf (latter option requires Expect.pm installed). A further option
9941 is to apply patches from the local disk or from CPAN.
9942
9943 CPAN.pm comes with a couple of such YAML files. The structure is
9944 currently not documented because in flux. Please see the distroprefs
9945 directory of the CPAN distribution for examples and follow the README
9946 in there.
9947
9948 Please note that setting the environment variable PERL_MM_USE_DEFAULT
9949 to a true value can also get you a long way if you want to always pick
9950 the default answers. But this only works if the author of a package
9951 used the prompt function provided by ExtUtils::MakeMaker and if the
9952 defaults are OK for you.
9953
9954 =head1 SECURITY
9955
9956 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
9957 install foreign, unmasked, unsigned code on your machine. We compare
9958 to a checksum that comes from the net just as the distribution file
9959 itself. But we try to make it easy to add security on demand:
9960
9961 =head2 Cryptographically signed modules
9962
9963 Since release 1.77 CPAN.pm has been able to verify cryptographically
9964 signed module distributions using Module::Signature.  The CPAN modules
9965 can be signed by their authors, thus giving more security.  The simple
9966 unsigned MD5 checksums that were used before by CPAN protect mainly
9967 against accidental file corruption.
9968
9969 You will need to have Module::Signature installed, which in turn
9970 requires that you have at least one of Crypt::OpenPGP module or the
9971 command-line F<gpg> tool installed.
9972
9973 You will also need to be able to connect over the Internet to the public
9974 keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
9975
9976 The configuration parameter check_sigs is there to turn signature
9977 checking on or off.
9978
9979 =head1 EXPORT
9980
9981 Most functions in package CPAN are exported per default. The reason
9982 for this is that the primary use is intended for the cpan shell or for
9983 one-liners.
9984
9985 =head1 ENVIRONMENT
9986
9987 When the CPAN shell enters a subshell via the look command, it sets
9988 the environment CPAN_SHELL_LEVEL to 1 or increments it if it is
9989 already set.
9990
9991 When the config variable ftp_passive is set, all downloads will be run
9992 with the environment variable FTP_PASSIVE set to this value. This is
9993 in general a good idea as it influences both Net::FTP and LWP based
9994 connections. The same effect can be achieved by starting the cpan
9995 shell with this environment variable set. For Net::FTP alone, one can
9996 also always set passive mode by running libnetcfg.
9997
9998 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
9999
10000 Populating a freshly installed perl with my favorite modules is pretty
10001 easy if you maintain a private bundle definition file. To get a useful
10002 blueprint of a bundle definition file, the command autobundle can be used
10003 on the CPAN shell command line. This command writes a bundle definition
10004 file for all modules that are installed for the currently running perl
10005 interpreter. It's recommended to run this command only once and from then
10006 on maintain the file manually under a private name, say
10007 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
10008
10009     cpan> install Bundle::my_bundle
10010
10011 then answer a few questions and then go out for a coffee.
10012
10013 Maintaining a bundle definition file means keeping track of two
10014 things: dependencies and interactivity. CPAN.pm sometimes fails on
10015 calculating dependencies because not all modules define all MakeMaker
10016 attributes correctly, so a bundle definition file should specify
10017 prerequisites as early as possible. On the other hand, it's a bit
10018 annoying that many distributions need some interactive configuring. So
10019 what I try to accomplish in my private bundle file is to have the
10020 packages that need to be configured early in the file and the gentle
10021 ones later, so I can go out after a few minutes and leave CPAN.pm
10022 untended.
10023
10024 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
10025
10026 Thanks to Graham Barr for contributing the following paragraphs about
10027 the interaction between perl, and various firewall configurations. For
10028 further information on firewalls, it is recommended to consult the
10029 documentation that comes with the ncftp program. If you are unable to
10030 go through the firewall with a simple Perl setup, it is very likely
10031 that you can configure ncftp so that it works for your firewall.
10032
10033 =head2 Three basic types of firewalls
10034
10035 Firewalls can be categorized into three basic types.
10036
10037 =over 4
10038
10039 =item http firewall
10040
10041 This is where the firewall machine runs a web server and to access the
10042 outside world you must do it via the web server. If you set environment
10043 variables like http_proxy or ftp_proxy to a values beginning with http://
10044 or in your web browser you have to set proxy information then you know
10045 you are running an http firewall.
10046
10047 To access servers outside these types of firewalls with perl (even for
10048 ftp) you will need to use LWP.
10049
10050 =item ftp firewall
10051
10052 This where the firewall machine runs an ftp server. This kind of
10053 firewall will only let you access ftp servers outside the firewall.
10054 This is usually done by connecting to the firewall with ftp, then
10055 entering a username like "user@outside.host.com"
10056
10057 To access servers outside these type of firewalls with perl you
10058 will need to use Net::FTP.
10059
10060 =item One way visibility
10061
10062 I say one way visibility as these firewalls try to make themselves look
10063 invisible to the users inside the firewall. An FTP data connection is
10064 normally created by sending the remote server your IP address and then
10065 listening for the connection. But the remote server will not be able to
10066 connect to you because of the firewall. So for these types of firewall
10067 FTP connections need to be done in a passive mode.
10068
10069 There are two that I can think off.
10070
10071 =over 4
10072
10073 =item SOCKS
10074
10075 If you are using a SOCKS firewall you will need to compile perl and link
10076 it with the SOCKS library, this is what is normally called a 'socksified'
10077 perl. With this executable you will be able to connect to servers outside
10078 the firewall as if it is not there.
10079
10080 =item IP Masquerade
10081
10082 This is the firewall implemented in the Linux kernel, it allows you to
10083 hide a complete network behind one IP address. With this firewall no
10084 special compiling is needed as you can access hosts directly.
10085
10086 For accessing ftp servers behind such firewalls you usually need to
10087 set the environment variable C<FTP_PASSIVE> or the config variable
10088 ftp_passive to a true value.
10089
10090 =back
10091
10092 =back
10093
10094 =head2 Configuring lynx or ncftp for going through a firewall
10095
10096 If you can go through your firewall with e.g. lynx, presumably with a
10097 command such as
10098
10099     /usr/local/bin/lynx -pscott:tiger
10100
10101 then you would configure CPAN.pm with the command
10102
10103     o conf lynx "/usr/local/bin/lynx -pscott:tiger"
10104
10105 That's all. Similarly for ncftp or ftp, you would configure something
10106 like
10107
10108     o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
10109
10110 Your mileage may vary...
10111
10112 =head1 FAQ
10113
10114 =over 4
10115
10116 =item 1)
10117
10118 I installed a new version of module X but CPAN keeps saying,
10119 I have the old version installed
10120
10121 Most probably you B<do> have the old version installed. This can
10122 happen if a module installs itself into a different directory in the
10123 @INC path than it was previously installed. This is not really a
10124 CPAN.pm problem, you would have the same problem when installing the
10125 module manually. The easiest way to prevent this behaviour is to add
10126 the argument C<UNINST=1> to the C<make install> call, and that is why
10127 many people add this argument permanently by configuring
10128
10129   o conf make_install_arg UNINST=1
10130
10131 =item 2)
10132
10133 So why is UNINST=1 not the default?
10134
10135 Because there are people who have their precise expectations about who
10136 may install where in the @INC path and who uses which @INC array. In
10137 fine tuned environments C<UNINST=1> can cause damage.
10138
10139 =item 3)
10140
10141 I want to clean up my mess, and install a new perl along with
10142 all modules I have. How do I go about it?
10143
10144 Run the autobundle command for your old perl and optionally rename the
10145 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
10146 with the Configure option prefix, e.g.
10147
10148     ./Configure -Dprefix=/usr/local/perl-5.6.78.9
10149
10150 Install the bundle file you produced in the first step with something like
10151
10152     cpan> install Bundle::mybundle
10153
10154 and you're done.
10155
10156 =item 4)
10157
10158 When I install bundles or multiple modules with one command
10159 there is too much output to keep track of.
10160
10161 You may want to configure something like
10162
10163   o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
10164   o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
10165
10166 so that STDOUT is captured in a file for later inspection.
10167
10168
10169 =item 5)
10170
10171 I am not root, how can I install a module in a personal directory?
10172
10173 First of all, you will want to use your own configuration, not the one
10174 that your root user installed. If you do not have permission to write
10175 in the cpan directory that root has configured, you will be asked if
10176 you want to create your own config. Answering "yes" will bring you into
10177 CPAN's configuration stage, using the system config for all defaults except
10178 things that have to do with CPAN's work directory, saving your choices to
10179 your MyConfig.pm file.
10180
10181 You can also manually initiate this process with the following command:
10182
10183     % perl -MCPAN -e 'mkmyconfig'
10184
10185 or by running
10186
10187     mkmyconfig
10188
10189 from the CPAN shell.
10190
10191 You will most probably also want to configure something like this:
10192
10193   o conf makepl_arg "LIB=~/myperl/lib \
10194                     INSTALLMAN1DIR=~/myperl/man/man1 \
10195                     INSTALLMAN3DIR=~/myperl/man/man3"
10196
10197 You can make this setting permanent like all C<o conf> settings with
10198 C<o conf commit>.
10199
10200 You will have to add ~/myperl/man to the MANPATH environment variable
10201 and also tell your perl programs to look into ~/myperl/lib, e.g. by
10202 including
10203
10204   use lib "$ENV{HOME}/myperl/lib";
10205
10206 or setting the PERL5LIB environment variable.
10207
10208 While we're speaking about $ENV{HOME}, it might be worth mentioning,
10209 that for Windows we use the File::HomeDir module that provides an
10210 equivalent to the concept of the home directory on Unix.
10211
10212 Another thing you should bear in mind is that the UNINST parameter can
10213 be dnagerous when you are installing into a private area because you
10214 might accidentally remove modules that other people depend on that are
10215 not using the private area.
10216
10217 =item 6)
10218
10219 How to get a package, unwrap it, and make a change before building it?
10220
10221 Have a look at the C<look> (!) command.
10222
10223 =item 7)
10224
10225 I installed a Bundle and had a couple of fails. When I
10226 retried, everything resolved nicely. Can this be fixed to work
10227 on first try?
10228
10229 The reason for this is that CPAN does not know the dependencies of all
10230 modules when it starts out. To decide about the additional items to
10231 install, it just uses data found in the META.yml file or the generated
10232 Makefile. An undetected missing piece breaks the process. But it may
10233 well be that your Bundle installs some prerequisite later than some
10234 depending item and thus your second try is able to resolve everything.
10235 Please note, CPAN.pm does not know the dependency tree in advance and
10236 cannot sort the queue of things to install in a topologically correct
10237 order. It resolves perfectly well IF all modules declare the
10238 prerequisites correctly with the PREREQ_PM attribute to MakeMaker or
10239 the C<requires> stanza of Module::Build. For bundles which fail and
10240 you need to install often, it is recommended to sort the Bundle
10241 definition file manually.
10242
10243 =item 8)
10244
10245 In our intranet we have many modules for internal use. How
10246 can I integrate these modules with CPAN.pm but without uploading
10247 the modules to CPAN?
10248
10249 Have a look at the CPAN::Site module.
10250
10251 =item 9)
10252
10253 When I run CPAN's shell, I get an error message about things in my
10254 /etc/inputrc (or ~/.inputrc) file.
10255
10256 These are readline issues and can only be fixed by studying readline
10257 configuration on your architecture and adjusting the referenced file
10258 accordingly. Please make a backup of the /etc/inputrc or ~/.inputrc
10259 and edit them. Quite often harmless changes like uppercasing or
10260 lowercasing some arguments solves the problem.
10261
10262 =item 10)
10263
10264 Some authors have strange characters in their names.
10265
10266 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
10267 expecting ISO-8859-1 charset, a converter can be activated by setting
10268 term_is_latin to a true value in your config file. One way of doing so
10269 would be
10270
10271     cpan> o conf term_is_latin 1
10272
10273 If other charset support is needed, please file a bugreport against
10274 CPAN.pm at rt.cpan.org and describe your needs. Maybe we can extend
10275 the support or maybe UTF-8 terminals become widely available.
10276
10277 =item 11)
10278
10279 When an install fails for some reason and then I correct the error
10280 condition and retry, CPAN.pm refuses to install the module, saying
10281 C<Already tried without success>.
10282
10283 Use the force pragma like so
10284
10285   force install Foo::Bar
10286
10287 This does a bit more than really needed because it untars the
10288 distribution again and runs make and test and only then install.
10289
10290 Or, if you find this is too fast and you would prefer to do smaller
10291 steps, say
10292
10293   force get Foo::Bar
10294
10295 first and then continue as always. C<Force get> I<forgets> previous
10296 error conditions.
10297
10298 Or you can use
10299
10300   look Foo::Bar
10301
10302 and then 'make install' directly in the subshell.
10303
10304 Or you leave the CPAN shell and start it again.
10305
10306 For the really curious, by accessing internals directly, you I<could>
10307
10308   !delete CPAN::Shell->expandany("Foo::Bar")->distribution->{install}
10309
10310 but this is neither guaranteed to work in the future nor is it a
10311 decent command.
10312
10313 =item 12)
10314
10315 How do I install a "DEVELOPER RELEASE" of a module?
10316
10317 By default, CPAN will install the latest non-developer release of a
10318 module. If you want to install a dev release, you have to specify the
10319 partial path starting with the author id to the tarball you wish to
10320 install, like so:
10321
10322     cpan> install KWILLIAMS/Module-Build-0.27_07.tar.gz
10323
10324 Note that you can use the C<ls> command to get this path listed.
10325
10326 =item 13)
10327
10328 How do I install a module and all its dependencies from the commandline,
10329 without being prompted for anything, despite my CPAN configuration
10330 (or lack thereof)?
10331
10332 CPAN uses ExtUtils::MakeMaker's prompt() function to ask its questions, so
10333 if you set the PERL_MM_USE_DEFAULT environment variable, you shouldn't be
10334 asked any questions at all (assuming the modules you are installing are
10335 nice about obeying that variable as well):
10336
10337     % PERL_MM_USE_DEFAULT=1 perl -MCPAN -e 'install My::Module'
10338
10339 =item 14)
10340
10341 How do I create a Module::Build based Build.PL derived from an
10342 ExtUtils::MakeMaker focused Makefile.PL?
10343
10344 http://search.cpan.org/search?query=Module::Build::Convert
10345
10346 http://accognoscere.org/papers/perl-module-build-convert/module-build-convert.html
10347
10348 =item 15)
10349
10350 What's the best CPAN site for me?
10351
10352 The urllist config parameter is yours. You can add and remove sites at
10353 will. You should find out which sites have the best uptodateness,
10354 bandwidth, reliability, etc. and are topologically close to you. Some
10355 people prefer fast downloads, others uptodateness, others reliability.
10356 You decide which to try in which order.
10357
10358 Henk P. Penning maintains a site that collects data about CPAN sites:
10359
10360   http://www.cs.uu.nl/people/henkp/mirmon/cpan.html
10361
10362 =back
10363
10364 =head1 BUGS
10365
10366 Please report bugs via http://rt.cpan.org/
10367
10368 Before submitting a bug, please make sure that the traditional method
10369 of building a Perl module package from a shell by following the
10370 installation instructions of that package still works in your
10371 environment.
10372
10373 =head1 SECURITY ADVICE
10374
10375 This software enables you to upgrade software on your computer and so
10376 is inherently dangerous because the newly installed software may
10377 contain bugs and may alter the way your computer works or even make it
10378 unusable. Please consider backing up your data before every upgrade.
10379
10380 =head1 AUTHOR
10381
10382 Andreas Koenig C<< <andk@cpan.org> >>
10383
10384 =head1 LICENSE
10385
10386 This program is free software; you can redistribute it and/or
10387 modify it under the same terms as Perl itself.
10388
10389 See L<http://www.perl.com/perl/misc/Artistic.html>
10390
10391 =head1 TRANSLATIONS
10392
10393 Kawai,Takanori provides a Japanese translation of this manpage at
10394 http://member.nifty.ne.jp/hippo2000/perltips/CPAN.htm
10395
10396 =head1 SEE ALSO
10397
10398 cpan(1), CPAN::Nox(3pm), CPAN::Version(3pm)
10399
10400 =cut