lib/CPAN.pm

   1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
   2 use strict;
   3 package CPAN;
   4 $CPAN::VERSION = '1.87_63';
   5 $CPAN::VERSION = eval $CPAN::VERSION;
   6
   7 use CPAN::HandleConfig;
   8 use CPAN::Version;
   9 use CPAN::Debug;
  10 use CPAN::Tarzip;
  11 use Carp ();
  12 use Config ();
  13 use Cwd ();
  14 use DirHandle ();
  15 use Exporter ();
  16 use ExtUtils::MakeMaker qw(prompt); # for some unknown reason,
  17                                     # 5.005_04 does not work without
  18                                     # this
  19 use File::Basename ();
  20 use File::Copy ();
  21 use File::Find;
  22 use File::Path ();
  23 use File::Spec ();
  24 use FileHandle ();
  25 use Safe ();
  26 use Sys::Hostname qw(hostname);
  27 use Text::ParseWords ();
  28 use Text::Wrap ();
  29
  30 # we need to run chdir all over and we would get at wrong libraries
  31 # there
  32 BEGIN {
  33     if (File::Spec->can("rel2abs")) {
  34         for my $inc (@INC) {
  35             $inc = File::Spec->rel2abs($inc);
  36         }
  37     }
  38 }
  39 no lib ".";
  40
  41 require Mac::BuildTools if $^O eq 'MacOS';
  42
  43 END { $CPAN::End++; &cleanup; }
  44
  45 $CPAN::Signal ||= 0;
  46 $CPAN::Frontend ||= "CPAN::Shell";
  47 unless (@CPAN::Defaultsites){
  48     @CPAN::Defaultsites = map {
  49         CPAN::URL->new(TEXT => $_, FROM => "DEF")
  50     }
  51         "http://www.perl.org/CPAN/",
  52             "ftp://ftp.perl.org/pub/CPAN/";
  53 }
  54 # $CPAN::iCwd (i for initial) is going to be initialized during find_perl
  55 $CPAN::Perl ||= CPAN::find_perl();
  56 $CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?";
  57 $CPAN::Defaultrecent ||= "http://search.cpan.org/recent";
  58
  59
  60 use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $HAS_USABLE $term
  61             $Signal $Suppress_readline $Frontend
  62             @Defaultsites $Have_warned $Defaultdocs $Defaultrecent
  63             $Be_Silent );
  64
  65 @CPAN::ISA = qw(CPAN::Debug Exporter);
  66
  67 # note that these functions live in CPAN::Shell and get executed via
  68 # AUTOLOAD when called directly
  69 @EXPORT = qw(
  70              autobundle
  71              bundle
  72              clean
  73              cvs_import
  74              expand
  75              force
  76              get
  77              install
  78              make
  79              mkmyconfig
  80              notest
  81              perldoc
  82              readme
  83              recent
  84              recompile
  85              shell
  86              test
  87              upgrade
  88             );
  89
  90 sub soft_chdir_with_alternatives ($);
  91
  92 #-> sub CPAN::AUTOLOAD ;
  93 sub AUTOLOAD {
  94     my($l) = $AUTOLOAD;
  95     $l =~ s/.*:://;
  96     my(%EXPORT);
  97     @EXPORT{@EXPORT} = '';
  98     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
  99     if (exists $EXPORT{$l}){
 100         CPAN::Shell->$l(@_);
 101     } else {
 102         die(qq{Unknown CPAN command "$AUTOLOAD". }.
 103             qq{Type ? for help.\n});
 104     }
 105 }
 106
 107 #-> sub CPAN::shell ;
 108 sub shell {
 109     my($self) = @_;
 110     $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
 111     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 112
 113     my $oprompt = shift || CPAN::Prompt->new;
 114     my $prompt = $oprompt;
 115     my $commandline = shift || "";
 116     $CPAN::CurrentCommandId ||= 1;
 117
 118     local($^W) = 1;
 119     unless ($Suppress_readline) {
 120         require Term::ReadLine;
 121         if (! $term
 122             or
 123             $term->ReadLine eq "Term::ReadLine::Stub"
 124            ) {
 125             $term = Term::ReadLine->new('CPAN Monitor');
 126         }
 127         if ($term->ReadLine eq "Term::ReadLine::Gnu") {
 128             my $attribs = $term->Attribs;
 129              $attribs->{attempted_completion_function} = sub {
 130                  &CPAN::Complete::gnu_cpl;
 131              }
 132         } else {
 133             $readline::rl_completion_function =
 134                 $readline::rl_completion_function = 'CPAN::Complete::cpl';
 135         }
 136         if (my $histfile = $CPAN::Config->{'histfile'}) {{
 137             unless ($term->can("AddHistory")) {
 138                 $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
 139                 last;
 140             }
 141             my($fh) = FileHandle->new;
 142             open $fh, "<$histfile" or last;
 143             local $/ = "\n";
 144             while (<$fh>) {
 145                 chomp;
 146                 $term->AddHistory($_);
 147             }
 148             close $fh;
 149         }}
 150         for ($CPAN::Config->{term_ornaments}) { # alias
 151             local $Term::ReadLine::termcap_nowarn = 1;
 152             $term->ornaments($_) if defined;
 153         }
 154         # $term->OUT is autoflushed anyway
 155         my $odef = select STDERR;
 156         $| = 1;
 157         select STDOUT;
 158         $| = 1;
 159         select $odef;
 160     }
 161
 162     # no strict; # I do not recall why no strict was here (2000-09-03)
 163     $META->checklock();
 164     my @cwd = (
 165                CPAN::anycwd(),
 166                File::Spec->can("tmpdir") ? File::Spec->tmpdir() : (),
 167                File::Spec->rootdir(),
 168               );
 169     my $try_detect_readline;
 170     $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
 171     my $rl_avail = $Suppress_readline ? "suppressed" :
 172         ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
 173             "available (try 'install Bundle::CPAN')";
 174
 175     unless ($CPAN::Config->{'inhibit_startup_message'}){
 176         $CPAN::Frontend->myprint(
 177                                  sprintf qq{
 178 cpan shell -- CPAN exploration and modules installation (v%s)
 179 ReadLine support %s
 180
 181 },
 182                                  $CPAN::VERSION,
 183                                  $rl_avail
 184                                 )
 185     }
 186     my($continuation) = "";
 187     my $last_term_ornaments;
 188   SHELLCOMMAND: while () {
 189         if ($Suppress_readline) {
 190             print $prompt;
 191             last SHELLCOMMAND unless defined ($_ = <> );
 192             chomp;
 193         } else {
 194             last SHELLCOMMAND unless
 195                 defined ($_ = $term->readline($prompt, $commandline));
 196         }
 197         $_ = "$continuation$_" if $continuation;
 198         s/^\s+//;
 199         next SHELLCOMMAND if /^$/;
 200         $_ = 'h' if /^\s*\?/;
 201         if (/^(?:q(?:uit)?|bye|exit)$/i) {
 202             last SHELLCOMMAND;
 203         } elsif (s/\\$//s) {
 204             chomp;
 205             $continuation = $_;
 206             $prompt = "    > ";
 207         } elsif (/^\!/) {
 208             s/^\!//;
 209             my($eval) = $_;
 210             package CPAN::Eval;
 211             use strict;
 212             use vars qw($import_done);
 213             CPAN->import(':DEFAULT') unless $import_done++;
 214             CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
 215             eval($eval);
 216             warn $@ if $@;
 217             $continuation = "";
 218             $prompt = $oprompt;
 219         } elsif (/./) {
 220             my(@line);
 221             if ($] < 5.00322) { # parsewords had a bug until recently
 222                 @line = split;
 223             } else {
 224                 eval { @line = Text::ParseWords::shellwords($_) };
 225                 warn($@), next SHELLCOMMAND if $@;
 226                 warn("Text::Parsewords could not parse the line [$_]"),
 227                     next SHELLCOMMAND unless @line;
 228             }
 229             $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
 230             my $command = shift @line;
 231             eval { CPAN::Shell->$command(@line) };
 232             warn $@ if $@;
 233             if ($command =~ /^(make|test|install|force|notest|clean|upgrade)$/) {
 234                 CPAN::Shell->failed($CPAN::CurrentCommandId,1);
 235             }
 236             soft_chdir_with_alternatives(\@cwd);
 237             $CPAN::Frontend->myprint("\n");
 238             $continuation = "";
 239             $CPAN::CurrentCommandId++;
 240             $prompt = $oprompt;
 241         }
 242     } continue {
 243       $commandline = ""; # I do want to be able to pass a default to
 244                          # shell, but on the second command I see no
 245                          # use in that
 246       $Signal=0;
 247       CPAN::Queue->nullify_queue;
 248       if ($try_detect_readline) {
 249         if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
 250             ||
 251             $CPAN::META->has_inst("Term::ReadLine::Perl")
 252            ) {
 253             delete $INC{"Term/ReadLine.pm"};
 254             my $redef = 0;
 255             local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
 256             require Term::ReadLine;
 257             $CPAN::Frontend->myprint("\n$redef subroutines in ".
 258                                      "Term::ReadLine redefined\n");
 259             @_ = ($oprompt,"");
 260             goto &shell;
 261         }
 262       }
 263       for ($CPAN::Config->{term_ornaments}) { # alias
 264           if (defined $_) {
 265               if (not defined $last_term_ornaments
 266                   or $_ != $last_term_ornaments
 267                  ) {
 268                   local $Term::ReadLine::termcap_nowarn = 1;
 269                   $term->ornaments($_);
 270                   $last_term_ornaments = $_;
 271               }
 272           } else {
 273               undef $last_term_ornaments;
 274           }
 275       }
 276     }
 277     soft_chdir_with_alternatives(\@cwd);
 278 }
 279
 280 sub soft_chdir_with_alternatives ($) {
 281     my($cwd) = @_;
 282     while (not chdir $cwd->[0]) {
 283         if (@$cwd>1) {
 284             $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $!
 285 Trying to chdir to "$cwd->[1]" instead.
 286 });
 287             shift @$cwd;
 288         } else {
 289             $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!});
 290         }
 291     }
 292 }
 293
 294 package CPAN::CacheMgr;
 295 use strict;
 296 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
 297 use File::Find;
 298
 299 package CPAN::FTP;
 300 use strict;
 301 use vars qw($Ua $Thesite $ThesiteURL $Themethod);
 302 @CPAN::FTP::ISA = qw(CPAN::Debug);
 303
 304 package CPAN::LWP::UserAgent;
 305 use strict;
 306 use vars qw(@ISA $USER $PASSWD $SETUPDONE);
 307 # we delay requiring LWP::UserAgent and setting up inheritance until we need it
 308
 309 package CPAN::Complete;
 310 use strict;
 311 @CPAN::Complete::ISA = qw(CPAN::Debug);
 312 @CPAN::Complete::COMMANDS = sort qw(
 313                                     ! a b d h i m o q r u
 314                                     autobundle
 315                                     clean
 316                                     cvs_import
 317                                     dump
 318                                     force
 319                                     install
 320                                     look
 321                                     ls
 322                                     make
 323                                     mkmyconfig
 324                                     notest
 325                                     perldoc
 326                                     readme
 327                                     recent
 328                                     recompile
 329                                     reload
 330                                     scripts
 331                                     test
 332                                     upgrade
 333 );
 334
 335 package CPAN::Index;
 336 use strict;
 337 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03);
 338 @CPAN::Index::ISA = qw(CPAN::Debug);
 339 $LAST_TIME ||= 0;
 340 $DATE_OF_03 ||= 0;
 341 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
 342 sub PROTOCOL { 2.0 }
 343
 344 package CPAN::InfoObj;
 345 use strict;
 346 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
 347
 348 package CPAN::Author;
 349 use strict;
 350 @CPAN::Author::ISA = qw(CPAN::InfoObj);
 351
 352 package CPAN::Distribution;
 353 use strict;
 354 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
 355
 356 package CPAN::Bundle;
 357 use strict;
 358 @CPAN::Bundle::ISA = qw(CPAN::Module);
 359
 360 package CPAN::Module;
 361 use strict;
 362 @CPAN::Module::ISA = qw(CPAN::InfoObj);
 363
 364 package CPAN::Exception::RecursiveDependency;
 365 use strict;
 366 use overload '""' => "as_string";
 367
 368 sub new {
 369     my($class) = shift;
 370     my($deps) = shift;
 371     my @deps;
 372     my %seen;
 373     for my $dep (@$deps) {
 374         push @deps, $dep;
 375         last if $seen{$dep}++;
 376     }
 377     bless { deps => \@deps }, $class;
 378 }
 379
 380 sub as_string {
 381     my($self) = shift;
 382     "\nRecursive dependency detected:\n    " .
 383         join("\n => ", @{$self->{deps}}) .
 384             ".\nCannot continue.\n";
 385 }
 386
 387 package CPAN::Prompt; use overload '""' => "as_string";
 388 use vars qw($prompt);
 389 $prompt = "cpan> ";
 390 $CPAN::CurrentCommandId ||= 0;
 391 sub new {
 392     bless {}, shift;
 393 }
 394 sub as_string {
 395     if ($CPAN::Config->{commandnumber_in_prompt}) {
 396         sprintf "cpan[%d]> ", $CPAN::CurrentCommandId;
 397     } else {
 398         "cpan> ";
 399     }
 400 }
 401
 402 package CPAN::URL; use overload '""' => "as_string", fallback => 1;
 403 # accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist),
 404 # planned are things like age or quality
 405 sub new {
 406     my($class,%args) = @_;
 407     bless {
 408            %args
 409           }, $class;
 410 }
 411 sub as_string {
 412     my($self) = @_;
 413     $self->text;
 414 }
 415 sub text {
 416     my($self,$set) = @_;
 417     if (defined $set) {
 418         $self->{TEXT} = $set;
 419     }
 420     $self->{TEXT};
 421 }
 422
 423 package CPAN::Distrostatus;
 424 use overload '""' => "as_string",
 425     fallback => 1;
 426 sub new {
 427     my($class,$arg) = @_;
 428     bless {
 429            TEXT => $arg,
 430            FAILED => substr($arg,0,2) eq "NO",
 431            COMMANDID => $CPAN::CurrentCommandId,
 432           }, $class;
 433 }
 434 sub commandid { shift->{COMMANDID} }
 435 sub failed { shift->{FAILED} }
 436 sub text {
 437     my($self,$set) = @_;
 438     if (defined $set) {
 439         $self->{TEXT} = $set;
 440     }
 441     $self->{TEXT};
 442 }
 443 sub as_string {
 444     my($self) = @_;
 445     $self->text;
 446 }
 447
 448 package CPAN::Shell;
 449 use strict;
 450 use vars qw($AUTOLOAD @ISA $COLOR_REGISTERED $ADVANCED_QUERY);
 451 @CPAN::Shell::ISA = qw(CPAN::Debug);
 452 $COLOR_REGISTERED ||= 0;
 453
 454 #-> sub CPAN::Shell::AUTOLOAD ;
 455 sub AUTOLOAD {
 456     my($autoload) = $AUTOLOAD;
 457     my $class = shift(@_);
 458     # warn "autoload[$autoload] class[$class]";
 459     $autoload =~ s/.*:://;
 460     if ($autoload =~ /^w/) {
 461         if ($CPAN::META->has_inst('CPAN::WAIT')) {
 462             CPAN::WAIT->$autoload(@_);
 463         } else {
 464             $CPAN::Frontend->mywarn(qq{
 465 Commands starting with "w" require CPAN::WAIT to be installed.
 466 Please consider installing CPAN::WAIT to use the fulltext index.
 467 For this you just need to type
 468     install CPAN::WAIT
 469 });
 470         }
 471     } else {
 472         $CPAN::Frontend->mywarn(qq{Unknown shell command '$autoload @_'. }.
 473                                 qq{Type ? for help.
 474 });
 475     }
 476 }
 477
 478 package CPAN::Queue;
 479 use strict;
 480
 481 # One use of the queue is to determine if we should or shouldn't
 482 # announce the availability of a new CPAN module
 483
 484 # Now we try to use it for dependency tracking. For that to happen
 485 # we need to draw a dependency tree and do the leaves first. This can
 486 # easily be reached by running CPAN.pm recursively, but we don't want
 487 # to waste memory and run into deep recursion. So what we can do is
 488 # this:
 489
 490 # CPAN::Queue is the package where the queue is maintained. Dependencies
 491 # often have high priority and must be brought to the head of the queue,
 492 # possibly by jumping the queue if they are already there. My first code
 493 # attempt tried to be extremely correct. Whenever a module needed
 494 # immediate treatment, I either unshifted it to the front of the queue,
 495 # or, if it was already in the queue, I spliced and let it bypass the
 496 # others. This became a too correct model that made it impossible to put
 497 # an item more than once into the queue. Why would you need that? Well,
 498 # you need temporary duplicates as the manager of the queue is a loop
 499 # that
 500 #
 501 #  (1) looks at the first item in the queue without shifting it off
 502 #
 503 #  (2) cares for the item
 504 #
 505 #  (3) removes the item from the queue, *even if its agenda failed and
 506 #      even if the item isn't the first in the queue anymore* (that way
 507 #      protecting against never ending queues)
 508 #
 509 # So if an item has prerequisites, the installation fails now, but we
 510 # want to retry later. That's easy if we have it twice in the queue.
 511 #
 512 # I also expect insane dependency situations where an item gets more
 513 # than two lives in the queue. Simplest example is triggered by 'install
 514 # Foo Foo Foo'. People make this kind of mistakes and I don't want to
 515 # get in the way. I wanted the queue manager to be a dumb servant, not
 516 # one that knows everything.
 517 #
 518 # Who would I tell in this model that the user wants to be asked before
 519 # processing? I can't attach that information to the module object,
 520 # because not modules are installed but distributions. So I'd have to
 521 # tell the distribution object that it should ask the user before
 522 # processing. Where would the question be triggered then? Most probably
 523 # in CPAN::Distribution::rematein.
 524 # Hope that makes sense, my head is a bit off:-) -- AK
 525
 526 use vars qw{ @All };
 527
 528 # CPAN::Queue::new ;
 529 sub new {
 530   my($class,$s) = @_;
 531   my $self = bless { qmod => $s }, $class;
 532   push @All, $self;
 533   return $self;
 534 }
 535
 536 # CPAN::Queue::first ;
 537 sub first {
 538   my $obj = $All[0];
 539   $obj->{qmod};
 540 }
 541
 542 # CPAN::Queue::delete_first ;
 543 sub delete_first {
 544   my($class,$what) = @_;
 545   my $i;
 546   for my $i (0..$#All) {
 547     if (  $All[$i]->{qmod} eq $what ) {
 548       splice @All, $i, 1;
 549       return;
 550     }
 551   }
 552 }
 553
 554 # CPAN::Queue::jumpqueue ;
 555 sub jumpqueue {
 556     my $class = shift;
 557     my @what = @_;
 558     CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]",
 559                         join(",",map {$_->{qmod}} @All),
 560                         join(",",@what)
 561                        )) if $CPAN::DEBUG;
 562   WHAT: for my $what (reverse @what) {
 563         my $jumped = 0;
 564         for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
 565             CPAN->debug("i[$All[$i]]what[$what]") if $CPAN::DEBUG;
 566             if ($All[$i]->{qmod} eq $what){
 567                 $jumped++;
 568                 if ($jumped > 100) { # one's OK if e.g. just
 569                                      # processing now; more are OK if
 570                                      # user typed it several times
 571                     $CPAN::Frontend->mywarn(
 572 qq{Object [$what] queued more than 100 times, ignoring}
 573                                  );
 574                     next WHAT;
 575                 }
 576             }
 577         }
 578         my $obj = bless { qmod => $what }, $class;
 579         unshift @All, $obj;
 580     }
 581     CPAN->debug(sprintf("after jumpqueue All[%s] what[%s]",
 582                         join(",",map {$_->{qmod}} @All),
 583                         join(",",@what)
 584                        )) if $CPAN::DEBUG;
 585 }
 586
 587 # CPAN::Queue::exists ;
 588 sub exists {
 589   my($self,$what) = @_;
 590   my @all = map { $_->{qmod} } @All;
 591   my $exists = grep { $_->{qmod} eq $what } @All;
 592   # warn "in exists what[$what] all[@all] exists[$exists]";
 593   $exists;
 594 }
 595
 596 # CPAN::Queue::delete ;
 597 sub delete {
 598   my($self,$mod) = @_;
 599   @All = grep { $_->{qmod} ne $mod } @All;
 600 }
 601
 602 # CPAN::Queue::nullify_queue ;
 603 sub nullify_queue {
 604   @All = ();
 605 }
 606
 607
 608
 609 package CPAN;
 610 use strict;
 611
 612 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
 613
 614 # from here on only subs.
 615 ################################################################################
 616
 617 sub suggest_myconfig () {
 618   SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) {
 619         $CPAN::Frontend->myprint("You don't seem to have a user ".
 620                                  "configuration (MyConfig.pm) yet.\n");
 621         my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ".
 622                                               "user configuration now? (Y/n)",
 623                                               "yes");
 624         if($new =~ m{^y}i) {
 625             CPAN::Shell->mkmyconfig();
 626             return &checklock;
 627         } else {
 628             $CPAN::Frontend->mydie("OK, giving up.");
 629         }
 630     }
 631 }
 632
 633 #-> sub CPAN::all_objects ;
 634 sub all_objects {
 635     my($mgr,$class) = @_;
 636     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 637     CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
 638     CPAN::Index->reload;
 639     values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
 640 }
 641 *all = \&all_objects;
 642
 643 # Called by shell, not in batch mode. In batch mode I see no risk in
 644 # having many processes updating something as installations are
 645 # continually checked at runtime. In shell mode I suspect it is
 646 # unintentional to open more than one shell at a time
 647
 648 #-> sub CPAN::checklock ;
 649 sub checklock {
 650     my($self) = @_;
 651     my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
 652     if (-f $lockfile && -M _ > 0) {
 653         my $fh = FileHandle->new($lockfile) or
 654             $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
 655         my $otherpid  = <$fh>;
 656         my $otherhost = <$fh>;
 657         $fh->close;
 658         if (defined $otherpid && $otherpid) {
 659             chomp $otherpid;
 660         }
 661         if (defined $otherhost && $otherhost) {
 662             chomp $otherhost;
 663         }
 664         my $thishost  = hostname();
 665         if (defined $otherhost && defined $thishost &&
 666             $otherhost ne '' && $thishost ne '' &&
 667             $otherhost ne $thishost) {
 668             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
 669                                            "reports other host $otherhost and other ".
 670                                            "process $otherpid.\n".
 671                                            "Cannot proceed.\n"));
 672         }
 673         elsif (defined $otherpid && $otherpid) {
 674             return if $$ == $otherpid; # should never happen
 675             $CPAN::Frontend->mywarn(
 676                                     qq{
 677 There seems to be running another CPAN process (pid $otherpid).  Contacting...
 678 });
 679             if (kill 0, $otherpid) {
 680                 $CPAN::Frontend->mydie(qq{Other job is running.
 681 You may want to kill it and delete the lockfile, maybe. On UNIX try:
 682     kill $otherpid
 683     rm $lockfile
 684 });
 685             } elsif (-w $lockfile) {
 686                 my($ans) =
 687                     CPAN::Shell::colorable_makemaker_prompt
 688                         (qq{Other job not responding. Shall I overwrite }.
 689                          qq{the lockfile '$lockfile'? (Y/n)},"y");
 690                 $CPAN::Frontend->myexit("Ok, bye\n")
 691                     unless $ans =~ /^y/i;
 692             } else {
 693                 Carp::croak(
 694                             qq{Lockfile '$lockfile' not writeable by you. }.
 695                             qq{Cannot proceed.\n}.
 696                             qq{    On UNIX try:\n}.
 697                             qq{    rm '$lockfile'\n}.
 698                             qq{  and then rerun us.\n}
 699                            );
 700             }
 701         } else {
 702             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
 703                                            "reports other process with ID ".
 704                                            "$otherpid. Cannot proceed.\n"));
 705         }
 706     }
 707     my $dotcpan = $CPAN::Config->{cpan_home};
 708     eval { File::Path::mkpath($dotcpan);};
 709     if ($@) {
 710         # A special case at least for Jarkko.
 711         my $firsterror = $@;
 712         my $seconderror;
 713         my $symlinkcpan;
 714         if (-l $dotcpan) {
 715             $symlinkcpan = readlink $dotcpan;
 716             die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
 717             eval { File::Path::mkpath($symlinkcpan); };
 718             if ($@) {
 719                 $seconderror = $@;
 720             } else {
 721                 $CPAN::Frontend->mywarn(qq{
 722 Working directory $symlinkcpan created.
 723 });
 724             }
 725         }
 726         unless (-d $dotcpan) {
 727             my $mess = qq{
 728 Your configuration suggests "$dotcpan" as your
 729 CPAN.pm working directory. I could not create this directory due
 730 to this error: $firsterror\n};
 731             $mess .= qq{
 732 As "$dotcpan" is a symlink to "$symlinkcpan",
 733 I tried to create that, but I failed with this error: $seconderror
 734 } if $seconderror;
 735             $mess .= qq{
 736 Please make sure the directory exists and is writable.
 737 };
 738             $CPAN::Frontend->myprint($mess);
 739             return suggest_myconfig;
 740         }
 741     } # $@ after eval mkpath $dotcpan
 742     my $fh;
 743     unless ($fh = FileHandle->new(">$lockfile")) {
 744         if ($! =~ /Permission/) {
 745             $CPAN::Frontend->myprint(qq{
 746
 747 Your configuration suggests that CPAN.pm should use a working
 748 directory of
 749     $CPAN::Config->{cpan_home}
 750 Unfortunately we could not create the lock file
 751     $lockfile
 752 due to permission problems.
 753
 754 Please make sure that the configuration variable
 755     \$CPAN::Config->{cpan_home}
 756 points to a directory where you can write a .lock file. You can set
 757 this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
 758 \@INC path;
 759 });
 760             return suggest_myconfig;
 761         }
 762     }
 763     $fh->print($$, "\n");
 764     $fh->print(hostname(), "\n");
 765     $self->{LOCK} = $lockfile;
 766     $fh->close;
 767     $SIG{TERM} = sub {
 768       &cleanup;
 769       $CPAN::Frontend->mydie("Got SIGTERM, leaving");
 770     };
 771     $SIG{INT} = sub {
 772       # no blocks!!!
 773       &cleanup if $Signal;
 774       $CPAN::Frontend->mydie("Got another SIGINT") if $Signal;
 775       print "Caught SIGINT\n";
 776       $Signal++;
 777     };
 778
 779 #       From: Larry Wall <larry@wall.org>
 780 #       Subject: Re: deprecating SIGDIE
 781 #       To: perl5-porters@perl.org
 782 #       Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
 783 #
 784 #       The original intent of __DIE__ was only to allow you to substitute one
 785 #       kind of death for another on an application-wide basis without respect
 786 #       to whether you were in an eval or not.  As a global backstop, it should
 787 #       not be used any more lightly (or any more heavily :-) than class
 788 #       UNIVERSAL.  Any attempt to build a general exception model on it should
 789 #       be politely squashed.  Any bug that causes every eval {} to have to be
 790 #       modified should be not so politely squashed.
 791 #
 792 #       Those are my current opinions.  It is also my optinion that polite
 793 #       arguments degenerate to personal arguments far too frequently, and that
 794 #       when they do, it's because both people wanted it to, or at least didn't
 795 #       sufficiently want it not to.
 796 #
 797 #       Larry
 798
 799     # global backstop to cleanup if we should really die
 800     $SIG{__DIE__} = \&cleanup;
 801     $self->debug("Signal handler set.") if $CPAN::DEBUG;
 802 }
 803
 804 #-> sub CPAN::DESTROY ;
 805 sub DESTROY {
 806     &cleanup; # need an eval?
 807 }
 808
 809 #-> sub CPAN::anycwd ;
 810 sub anycwd () {
 811     my $getcwd;
 812     $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
 813     CPAN->$getcwd();
 814 }
 815
 816 #-> sub CPAN::cwd ;
 817 sub cwd {Cwd::cwd();}
 818
 819 #-> sub CPAN::getcwd ;
 820 sub getcwd {Cwd::getcwd();}
 821
 822 #-> sub CPAN::fastcwd ;
 823 sub fastcwd {Cwd::fastcwd();}
 824
 825 #-> sub CPAN::backtickcwd ;
 826 sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
 827
 828 #-> sub CPAN::find_perl ;
 829 sub find_perl {
 830     my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
 831     my $pwd  = $CPAN::iCwd = CPAN::anycwd();
 832     my $candidate = File::Spec->catfile($pwd,$^X);
 833     $perl ||= $candidate if MM->maybe_command($candidate);
 834
 835     unless ($perl) {
 836         my ($component,$perl_name);
 837       DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
 838             PATH_COMPONENT: foreach $component (File::Spec->path(),
 839                                                 $Config::Config{'binexp'}) {
 840                   next unless defined($component) && $component;
 841                   my($abs) = File::Spec->catfile($component,$perl_name);
 842                   if (MM->maybe_command($abs)) {
 843                       $perl = $abs;
 844                       last DIST_PERLNAME;
 845                   }
 846               }
 847           }
 848     }
 849
 850     return $perl;
 851 }
 852
 853
 854 #-> sub CPAN::exists ;
 855 sub exists {
 856     my($mgr,$class,$id) = @_;
 857     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 858     CPAN::Index->reload;
 859     ### Carp::croak "exists called without class argument" unless $class;
 860     $id ||= "";
 861     $id =~ s/:+/::/g if $class eq "CPAN::Module";
 862     exists $META->{readonly}{$class}{$id} or
 863         exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
 864 }
 865
 866 #-> sub CPAN::delete ;
 867 sub delete {
 868   my($mgr,$class,$id) = @_;
 869   delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
 870   delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
 871 }
 872
 873 #-> sub CPAN::has_usable
 874 # has_inst is sometimes too optimistic, we should replace it with this
 875 # has_usable whenever a case is given
 876 sub has_usable {
 877     my($self,$mod,$message) = @_;
 878     return 1 if $HAS_USABLE->{$mod};
 879     my $has_inst = $self->has_inst($mod,$message);
 880     return unless $has_inst;
 881     my $usable;
 882     $usable = {
 883                LWP => [ # we frequently had "Can't locate object
 884                         # method "new" via package "LWP::UserAgent" at
 885                         # (eval 69) line 2006
 886                        sub {require LWP},
 887                        sub {require LWP::UserAgent},
 888                        sub {require HTTP::Request},
 889                        sub {require URI::URL},
 890                       ],
 891                'Net::FTP' => [
 892                             sub {require Net::FTP},
 893                             sub {require Net::Config},
 894                            ],
 895                'File::HomeDir' => [
 896                                    sub {require File::HomeDir;
 897                                         unless (File::HomeDir->VERSION >= 0.52){
 898                                             for ("Will not use File::HomeDir, need 0.52\n") {
 899                                                 $CPAN::Frontend->mywarn($_);
 900                                                 die $_;
 901                                             }
 902                                         }
 903                                     },
 904                                   ],
 905               };
 906     if ($usable->{$mod}) {
 907         for my $c (0..$#{$usable->{$mod}}) {
 908             my $code = $usable->{$mod}[$c];
 909             my $ret = eval { &$code() };
 910             $ret = "" unless defined $ret;
 911             if ($@) {
 912                 # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
 913                 return;
 914             }
 915         }
 916     }
 917     return $HAS_USABLE->{$mod} = 1;
 918 }
 919
 920 #-> sub CPAN::has_inst
 921 sub has_inst {
 922     my($self,$mod,$message) = @_;
 923     Carp::croak("CPAN->has_inst() called without an argument")
 924         unless defined $mod;
 925     my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
 926         keys %{$CPAN::Config->{dontload_hash}||{}},
 927             @{$CPAN::Config->{dontload_list}||[]};
 928     if (defined $message && $message eq "no"  # afair only used by Nox
 929         ||
 930         $dont{$mod}
 931        ) {
 932       $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
 933       return 0;
 934     }
 935     my $file = $mod;
 936     my $obj;
 937     $file =~ s|::|/|g;
 938     $file .= ".pm";
 939     if ($INC{$file}) {
 940         # checking %INC is wrong, because $INC{LWP} may be true
 941         # although $INC{"URI/URL.pm"} may have failed. But as
 942         # I really want to say "bla loaded OK", I have to somehow
 943         # cache results.
 944         ### warn "$file in %INC"; #debug
 945         return 1;
 946     } elsif (eval { require $file }) {
 947         # eval is good: if we haven't yet read the database it's
 948         # perfect and if we have installed the module in the meantime,
 949         # it tries again. The second require is only a NOOP returning
 950         # 1 if we had success, otherwise it's retrying
 951
 952         $CPAN::Frontend->myprint("CPAN: $mod loaded ok\n");
 953         if ($mod eq "CPAN::WAIT") {
 954             push @CPAN::Shell::ISA, 'CPAN::WAIT';
 955         }
 956         return 1;
 957     } elsif ($mod eq "Net::FTP") {
 958         $CPAN::Frontend->mywarn(qq{
 959   Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
 960   if you just type
 961       install Bundle::libnet
 962
 963 }) unless $Have_warned->{"Net::FTP"}++;
 964         $CPAN::Frontend->mysleep(3);
 965     } elsif ($mod eq "Digest::SHA"){
 966         if ($Have_warned->{"Digest::SHA"}++) {
 967             $CPAN::Frontend->myprint(qq{CPAN: checksum security checks disabled}.
 968                                      qq{because Digest::SHA not installed.\n});
 969         } else {
 970             $CPAN::Frontend->mywarn(qq{
 971   CPAN: checksum security checks disabled because Digest::SHA not installed.
 972   Please consider installing the Digest::SHA module.
 973
 974 });
 975             $CPAN::Frontend->mysleep(2);
 976         }
 977     } elsif ($mod eq "Module::Signature"){
 978         if (not $CPAN::Config->{check_sigs}) {
 979             # they do not want us:-(
 980         } elsif (not $Have_warned->{"Module::Signature"}++) {
 981             # No point in complaining unless the user can
 982             # reasonably install and use it.
 983             if (eval { require Crypt::OpenPGP; 1 } ||
 984                 (
 985                  defined $CPAN::Config->{'gpg'}
 986                  &&
 987                  $CPAN::Config->{'gpg'} =~ /\S/
 988                 )
 989                ) {
 990                 $CPAN::Frontend->mywarn(qq{
 991   CPAN: Module::Signature security checks disabled because Module::Signature
 992   not installed.  Please consider installing the Module::Signature module.
 993   You may also need to be able to connect over the Internet to the public
 994   keyservers like pgp.mit.edu (port 11371).
 995
 996 });
 997                 $CPAN::Frontend->mysleep(2);
 998             }
 999         }
1000     } else {
1001         delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
1002     }
1003     return 0;
1004 }
1005
1006 #-> sub CPAN::instance ;
1007 sub instance {
1008     my($mgr,$class,$id) = @_;
1009     CPAN::Index->reload;
1010     $id ||= "";
1011     # unsafe meta access, ok?
1012     return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
1013     $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
1014 }
1015
1016 #-> sub CPAN::new ;
1017 sub new {
1018     bless {}, shift;
1019 }
1020
1021 #-> sub CPAN::cleanup ;
1022 sub cleanup {
1023   # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
1024   local $SIG{__DIE__} = '';
1025   my($message) = @_;
1026   my $i = 0;
1027   my $ineval = 0;
1028   my($subroutine);
1029   while ((undef,undef,undef,$subroutine) = caller(++$i)) {
1030       $ineval = 1, last if
1031           $subroutine eq '(eval)';
1032   }
1033   return if $ineval && !$CPAN::End;
1034   return unless defined $META->{LOCK};
1035   return unless -f $META->{LOCK};
1036   $META->savehist;
1037   unlink $META->{LOCK};
1038   # require Carp;
1039   # Carp::cluck("DEBUGGING");
1040   $CPAN::Frontend->myprint("Lockfile removed.\n");
1041 }
1042
1043 #-> sub CPAN::savehist
1044 sub savehist {
1045     my($self) = @_;
1046     my($histfile,$histsize);
1047     unless ($histfile = $CPAN::Config->{'histfile'}){
1048         $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
1049         return;
1050     }
1051     $histsize = $CPAN::Config->{'histsize'} || 100;
1052     if ($CPAN::term){
1053         unless ($CPAN::term->can("GetHistory")) {
1054             $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
1055             return;
1056         }
1057     } else {
1058         return;
1059     }
1060     my @h = $CPAN::term->GetHistory;
1061     splice @h, 0, @h-$histsize if @h>$histsize;
1062     my($fh) = FileHandle->new;
1063     open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
1064     local $\ = local $, = "\n";
1065     print $fh @h;
1066     close $fh;
1067 }
1068
1069 sub is_tested {
1070     my($self,$what) = @_;
1071     $self->{is_tested}{$what} = 1;
1072 }
1073
1074 sub is_installed {
1075     my($self,$what) = @_;
1076     delete $self->{is_tested}{$what};
1077 }
1078
1079 sub set_perl5lib {
1080     my($self) = @_;
1081     $self->{is_tested} ||= {};
1082     return unless %{$self->{is_tested}};
1083     my $env = $ENV{PERL5LIB};
1084     $env = $ENV{PERLLIB} unless defined $env;
1085     my @env;
1086     push @env, $env if defined $env and length $env;
1087     my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
1088     $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
1089     $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1090 }
1091
1092 package CPAN::CacheMgr;
1093 use strict;
1094
1095 #-> sub CPAN::CacheMgr::as_string ;
1096 sub as_string {
1097     eval { require Data::Dumper };
1098     if ($@) {
1099         return shift->SUPER::as_string;
1100     } else {
1101         return Data::Dumper::Dumper(shift);
1102     }
1103 }
1104
1105 #-> sub CPAN::CacheMgr::cachesize ;
1106 sub cachesize {
1107     shift->{DU};
1108 }
1109
1110 #-> sub CPAN::CacheMgr::tidyup ;
1111 sub tidyup {
1112   my($self) = @_;
1113   return unless -d $self->{ID};
1114   while ($self->{DU} > $self->{'MAX'} ) {
1115     my($toremove) = shift @{$self->{FIFO}};
1116     $CPAN::Frontend->myprint(sprintf(
1117                                      "Deleting from cache".
1118                                      ": $toremove (%.1f>%.1f MB)\n",
1119                                      $self->{DU}, $self->{'MAX'})
1120                             );
1121     return if $CPAN::Signal;
1122     $self->force_clean_cache($toremove);
1123     return if $CPAN::Signal;
1124   }
1125 }
1126
1127 #-> sub CPAN::CacheMgr::dir ;
1128 sub dir {
1129     shift->{ID};
1130 }
1131
1132 #-> sub CPAN::CacheMgr::entries ;
1133 sub entries {
1134     my($self,$dir) = @_;
1135     return unless defined $dir;
1136     $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
1137     $dir ||= $self->{ID};
1138     my($cwd) = CPAN::anycwd();
1139     chdir $dir or Carp::croak("Can't chdir to $dir: $!");
1140     my $dh = DirHandle->new(File::Spec->curdir)
1141         or Carp::croak("Couldn't opendir $dir: $!");
1142     my(@entries);
1143     for ($dh->read) {
1144         next if $_ eq "." || $_ eq "..";
1145         if (-f $_) {
1146             push @entries, File::Spec->catfile($dir,$_);
1147         } elsif (-d _) {
1148             push @entries, File::Spec->catdir($dir,$_);
1149         } else {
1150             $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
1151         }
1152     }
1153     chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
1154     sort { -M $b <=> -M $a} @entries;
1155 }
1156
1157 #-> sub CPAN::CacheMgr::disk_usage ;
1158 sub disk_usage {
1159     my($self,$dir) = @_;
1160     return if exists $self->{SIZE}{$dir};
1161     return if $CPAN::Signal;
1162     my($Du) = 0;
1163     if (-e $dir) {
1164         unless (-x $dir) {
1165             unless (chmod 0755, $dir) {
1166                 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
1167                                         "permission to change the permission; cannot ".
1168                                         "estimate disk usage of '$dir'\n");
1169                 $CPAN::Frontend->mysleep(5);
1170                 return;
1171             }
1172         }
1173     } else {
1174         $CPAN::Frontend->mywarn("Directory '$dir' has gone. Cannot continue.\n");
1175         $CPAN::Frontend->mysleep(2);
1176         return;
1177     }
1178     find(
1179          sub {
1180            $File::Find::prune++ if $CPAN::Signal;
1181            return if -l $_;
1182            if ($^O eq 'MacOS') {
1183              require Mac::Files;
1184              my $cat  = Mac::Files::FSpGetCatInfo($_);
1185              $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
1186            } else {
1187              if (-d _) {
1188                unless (-x _) {
1189                  unless (chmod 0755, $_) {
1190                    $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
1191                                            "the permission to change the permission; ".
1192                                            "can only partially estimate disk usage ".
1193                                            "of '$_'\n");
1194                    $CPAN::Frontend->mysleep(5);
1195                    return;
1196                  }
1197                }
1198              } else {
1199                $Du += (-s _);
1200              }
1201            }
1202          },
1203          $dir
1204         );
1205     return if $CPAN::Signal;
1206     $self->{SIZE}{$dir} = $Du/1024/1024;
1207     push @{$self->{FIFO}}, $dir;
1208     $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
1209     $self->{DU} += $Du/1024/1024;
1210     $self->{DU};
1211 }
1212
1213 #-> sub CPAN::CacheMgr::force_clean_cache ;
1214 sub force_clean_cache {
1215     my($self,$dir) = @_;
1216     return unless -e $dir;
1217     $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
1218         if $CPAN::DEBUG;
1219     File::Path::rmtree($dir);
1220     $self->{DU} -= $self->{SIZE}{$dir};
1221     delete $self->{SIZE}{$dir};
1222 }
1223
1224 #-> sub CPAN::CacheMgr::new ;
1225 sub new {
1226     my $class = shift;
1227     my $time = time;
1228     my($debug,$t2);
1229     $debug = "";
1230     my $self = {
1231                 ID => $CPAN::Config->{'build_dir'},
1232                 MAX => $CPAN::Config->{'build_cache'},
1233                 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
1234                 DU => 0
1235                };
1236     File::Path::mkpath($self->{ID});
1237     my $dh = DirHandle->new($self->{ID});
1238     bless $self, $class;
1239     $self->scan_cache;
1240     $t2 = time;
1241     $debug .= "timing of CacheMgr->new: ".($t2 - $time);
1242     $time = $t2;
1243     CPAN->debug($debug) if $CPAN::DEBUG;
1244     $self;
1245 }
1246
1247 #-> sub CPAN::CacheMgr::scan_cache ;
1248 sub scan_cache {
1249     my $self = shift;
1250     return if $self->{SCAN} eq 'never';
1251     $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
1252         unless $self->{SCAN} eq 'atstart';
1253     $CPAN::Frontend->myprint(
1254                              sprintf("Scanning cache %s for sizes\n",
1255                                      $self->{ID}));
1256     my $e;
1257     for $e ($self->entries($self->{ID})) {
1258         next if $e eq ".." || $e eq ".";
1259         $self->disk_usage($e);
1260         return if $CPAN::Signal;
1261     }
1262     $self->tidyup;
1263 }
1264
1265 package CPAN::Shell;
1266 use strict;
1267
1268 #-> sub CPAN::Shell::h ;
1269 sub h {
1270     my($class,$about) = @_;
1271     if (defined $about) {
1272         $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1273     } else {
1274         my $filler = " " x (80 - 28 - length($CPAN::VERSION));
1275         $CPAN::Frontend->myprint(qq{
1276 Display Information $filler (ver $CPAN::VERSION)
1277  command  argument          description
1278  a,b,d,m  WORD or /REGEXP/  about authors, bundles, distributions, modules
1279  i        WORD or /REGEXP/  about any of the above
1280  ls       AUTHOR or GLOB    about files in the author's directory
1281     (with WORD being a module, bundle or author name or a distribution
1282     name of the form AUTHOR/DISTRIBUTION)
1283
1284 Download, Test, Make, Install...
1285  get      download                     clean    make clean
1286  make     make (implies get)           look     open subshell in dist directory
1287  test     make test (implies make)     readme   display these README files
1288  install  make install (implies test)  perldoc  display POD documentation
1289
1290 Pragmas
1291  force COMMAND    unconditionally do command
1292  notest COMMAND   skip testing
1293
1294 Other
1295  h,?           display this menu       ! perl-code   eval a perl command
1296  r             report module updates   upgrade       upgrade all modules
1297  o conf [opt]  set and query options   q             quit the cpan shell
1298  reload cpan   load CPAN.pm again      reload index  load newer indices
1299  autobundle    Snapshot                recent        latest CPAN uploads});
1300     }
1301 }
1302
1303 *help = \&h;
1304
1305 #-> sub CPAN::Shell::a ;
1306 sub a {
1307   my($self,@arg) = @_;
1308   # authors are always UPPERCASE
1309   for (@arg) {
1310     $_ = uc $_ unless /=/;
1311   }
1312   $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1313 }
1314
1315 #-> sub CPAN::Shell::globls ;
1316 sub globls {
1317     my($self,$s,$pragmas) = @_;
1318     # ls is really very different, but we had it once as an ordinary
1319     # command in the Shell (upto rev. 321) and we could not handle
1320     # force well then
1321     my(@accept,@preexpand);
1322     if ($s =~ /[\*\?\/]/) {
1323         if ($CPAN::META->has_inst("Text::Glob")) {
1324             if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
1325                 my $rau = Text::Glob::glob_to_regex(uc $au);
1326                 CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
1327                       if $CPAN::DEBUG;
1328                 push @preexpand, map { $_->id . "/" . $pathglob }
1329                     CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
1330             } else {
1331                 my $rau = Text::Glob::glob_to_regex(uc $s);
1332                 push @preexpand, map { $_->id }
1333                     CPAN::Shell->expand_by_method('CPAN::Author',
1334                                                   ['id'],
1335                                                   "/$rau/");
1336             }
1337         } else {
1338             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
1339         }
1340     } else {
1341         push @preexpand, uc $s;
1342     }
1343     for (@preexpand) {
1344         unless (/^[A-Z0-9\-]+(\/|$)/i) {
1345             $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
1346             next;
1347         }
1348         push @accept, $_;
1349     }
1350     my $silent = @accept>1;
1351     my $last_alpha = "";
1352     my @results;
1353     for my $a (@accept){
1354         my($author,$pathglob);
1355         if ($a =~ m|(.*?)/(.*)|) {
1356             my $a2 = $1;
1357             $pathglob = $2;
1358             $author = CPAN::Shell->expand_by_method('CPAN::Author',
1359                                                     ['id'],
1360                                                     $a2) or die "No author found for $a2";
1361         } else {
1362             $author = CPAN::Shell->expand_by_method('CPAN::Author',
1363                                                     ['id'],
1364                                                     $a) or die "No author found for $a";
1365         }
1366         if ($silent) {
1367             my $alpha = substr $author->id, 0, 1;
1368             my $ad;
1369             if ($alpha eq $last_alpha) {
1370                 $ad = "";
1371             } else {
1372                 $ad = "[$alpha]";
1373                 $last_alpha = $alpha;
1374             }
1375             $CPAN::Frontend->myprint($ad);
1376         }
1377         for my $pragma (@$pragmas) {
1378             if ($author->can($pragma)) {
1379                 $author->$pragma();
1380             }
1381         }
1382         push @results, $author->ls($pathglob,$silent); # silent if
1383                                                        # more than one
1384                                                        # author
1385         for my $pragma (@$pragmas) {
1386             my $meth = "un$pragma";
1387             if ($author->can($meth)) {
1388                 $author->$meth();
1389             }
1390         }
1391     }
1392     @results;
1393 }
1394
1395 #-> sub CPAN::Shell::local_bundles ;
1396 sub local_bundles {
1397     my($self,@which) = @_;
1398     my($incdir,$bdir,$dh);
1399     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1400         my @bbase = "Bundle";
1401         while (my $bbase = shift @bbase) {
1402             $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
1403             CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1404             if ($dh = DirHandle->new($bdir)) { # may fail
1405                 my($entry);
1406                 for $entry ($dh->read) {
1407                     next if $entry =~ /^\./;
1408                     next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/;
1409                     if (-d File::Spec->catdir($bdir,$entry)){
1410                         push @bbase, "$bbase\::$entry";
1411                     } else {
1412                         next unless $entry =~ s/\.pm(?!\n)\Z//;
1413                         $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1414                     }
1415                 }
1416             }
1417         }
1418     }
1419 }
1420
1421 #-> sub CPAN::Shell::b ;
1422 sub b {
1423     my($self,@which) = @_;
1424     CPAN->debug("which[@which]") if $CPAN::DEBUG;
1425     $self->local_bundles;
1426     $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1427 }
1428
1429 #-> sub CPAN::Shell::d ;
1430 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1431
1432 #-> sub CPAN::Shell::m ;
1433 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1434     my $self = shift;
1435     $CPAN::Frontend->myprint($self->format_result('Module',@_));
1436 }
1437
1438 #-> sub CPAN::Shell::i ;
1439 sub i {
1440     my($self) = shift;
1441     my(@args) = @_;
1442     @args = '/./' unless @args;
1443     my(@result);
1444     for my $type (qw/Bundle Distribution Module/) {
1445         push @result, $self->expand($type,@args);
1446     }
1447     # Authors are always uppercase.
1448     push @result, $self->expand("Author", map { uc $_ } @args);
1449
1450     my $result = @result == 1 ?
1451         $result[0]->as_string :
1452             @result == 0 ?
1453                 "No objects found of any type for argument @args\n" :
1454                     join("",
1455                          (map {$_->as_glimpse} @result),
1456                          scalar @result, " items found\n",
1457                         );
1458     $CPAN::Frontend->myprint($result);
1459 }
1460
1461 #-> sub CPAN::Shell::o ;
1462
1463 # CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o
1464 # conf' calls through to CPAN::HandleConfig::edit. 'o conf' should
1465 # have been called 'set' and 'o debug' maybe 'set debug' or 'debug'
1466 # 'o conf XXX' calls ->edit in CPAN/HandleConfig.pm
1467 sub o {
1468     my($self,$o_type,@o_what) = @_;
1469     $DB::single = 1;
1470     $o_type ||= "";
1471     CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1472     if ($o_type eq 'conf') {
1473         if (!@o_what) { # print all things, "o conf"
1474             my($k,$v);
1475             $CPAN::Frontend->myprint("\$CPAN::Config options from ");
1476             my @from;
1477             if (exists $INC{'CPAN/Config.pm'}) {
1478                 push @from, $INC{'CPAN/Config.pm'};
1479             }
1480             if (exists $INC{'CPAN/MyConfig.pm'}) {
1481                 push @from, $INC{'CPAN/MyConfig.pm'};
1482             }
1483             $CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from);
1484             $CPAN::Frontend->myprint(":\n");
1485             for $k (sort keys %CPAN::HandleConfig::can) {
1486                 $v = $CPAN::HandleConfig::can{$k};
1487                 $CPAN::Frontend->myprint(sprintf "    %-18s [%s]\n", $k, $v);
1488             }
1489             $CPAN::Frontend->myprint("\n");
1490             for $k (sort keys %$CPAN::Config) {
1491                 CPAN::HandleConfig->prettyprint($k);
1492             }
1493             $CPAN::Frontend->myprint("\n");
1494         } elsif (!CPAN::HandleConfig->edit(@o_what)) {
1495             $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
1496                                      qq{items\n\n});
1497         }
1498     } elsif ($o_type eq 'debug') {
1499         my(%valid);
1500         @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1501         if (@o_what) {
1502             while (@o_what) {
1503                 my($what) = shift @o_what;
1504                 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
1505                     $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
1506                     next;
1507                 }
1508                 if ( exists $CPAN::DEBUG{$what} ) {
1509                     $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1510                 } elsif ($what =~ /^\d/) {
1511                     $CPAN::DEBUG = $what;
1512                 } elsif (lc $what eq 'all') {
1513                     my($max) = 0;
1514                     for (values %CPAN::DEBUG) {
1515                         $max += $_;
1516                     }
1517                     $CPAN::DEBUG = $max;
1518                 } else {
1519                     my($known) = 0;
1520                     for (keys %CPAN::DEBUG) {
1521                         next unless lc($_) eq lc($what);
1522                         $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1523                         $known = 1;
1524                     }
1525                     $CPAN::Frontend->myprint("unknown argument [$what]\n")
1526                         unless $known;
1527                 }
1528             }
1529         } else {
1530           my $raw = "Valid options for debug are ".
1531               join(", ",sort(keys %CPAN::DEBUG), 'all').
1532                   qq{ or a number. Completion works on the options. }.
1533                       qq{Case is ignored.};
1534           require Text::Wrap;
1535           $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1536           $CPAN::Frontend->myprint("\n\n");
1537         }
1538         if ($CPAN::DEBUG) {
1539             $CPAN::Frontend->myprint("Options set for debugging:\n");
1540             my($k,$v);
1541             for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1542                 $v = $CPAN::DEBUG{$k};
1543                 $CPAN::Frontend->myprint(sprintf "    %-14s(%s)\n", $k, $v)
1544                     if $v & $CPAN::DEBUG;
1545             }
1546         } else {
1547             $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1548         }
1549     } else {
1550         $CPAN::Frontend->myprint(qq{
1551 Known options:
1552   conf    set or get configuration variables
1553   debug   set or get debugging options
1554 });
1555     }
1556 }
1557
1558 sub paintdots_onreload {
1559     my($ref) = shift;
1560     sub {
1561         if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
1562             my($subr) = $1;
1563             ++$$ref;
1564             local($|) = 1;
1565             # $CPAN::Frontend->myprint(".($subr)");
1566             $CPAN::Frontend->myprint(".");
1567             return;
1568         }
1569         warn @_;
1570     };
1571 }
1572
1573 #-> sub CPAN::Shell::reload ;
1574 sub reload {
1575     my($self,$command,@arg) = @_;
1576     $command ||= "";
1577     $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1578     if ($command =~ /cpan/i) {
1579         my $redef = 0;
1580         chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
1581         my $failed;
1582         my @relo = (
1583                     "CPAN.pm",
1584                     "CPAN/HandleConfig.pm",
1585                     "CPAN/FirstTime.pm",
1586                     "CPAN/Tarzip.pm",
1587                     "CPAN/Debug.pm",
1588                     "CPAN/Version.pm",
1589                    );
1590         if ($CPAN::Config->{test_report}) {
1591             push @relo, "CPAN/Reporter.pm";
1592         }
1593       MFILE: for my $f (@relo) {
1594             local($SIG{__WARN__}) = paintdots_onreload(\$redef);
1595             $self->reload_this($f) or $failed++;
1596         }
1597         $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1598         $failed++ unless $redef;
1599         if ($failed) {
1600             $CPAN::Frontend->mywarn("\n$failed errors during reload. You better quit ".
1601                                     "this session.\n");
1602         }
1603     } elsif ($command =~ /index/) {
1604       CPAN::Index->force_reload;
1605     } else {
1606       $CPAN::Frontend->myprint(qq{cpan     re-evals the CPAN.pm file
1607 index    re-reads the index files\n});
1608     }
1609 }
1610
1611 sub reload_this {
1612     my($self,$f) = @_;
1613     return 1 unless $INC{$f};
1614     my $pwd = CPAN::anycwd();
1615     CPAN->debug("reloading the whole '$f' from '$INC{$f}' while pwd='$pwd'")
1616         if $CPAN::DEBUG;
1617     my $read;
1618     for my $inc (@INC) {
1619         $read = File::Spec->catfile($inc,split /\//, $f);
1620         last if -f $read;
1621     }
1622     unless (-f $read) {
1623         $read = $INC{$f};
1624     }
1625     unless (-f $read) {
1626         $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
1627         return;
1628     }
1629     my $fh = FileHandle->new($read) or
1630         $CPAN::Frontend->mydie("Could not open $read: $!");
1631     local($/);
1632     local $^W = 1;
1633     my $eval = <$fh>;
1634     CPAN->debug(sprintf("evaling [%s...]\n",substr($eval,0,64)))
1635         if $CPAN::DEBUG;
1636     eval $eval;
1637     if ($@){
1638         warn $@;
1639         return;
1640     }
1641     return 1;
1642 }
1643
1644 #-> sub CPAN::Shell::mkmyconfig ;
1645 sub mkmyconfig {
1646     my($self, $cpanpm, %args) = @_;
1647     require CPAN::FirstTime;
1648     my $home = CPAN::HandleConfig::home;
1649     $cpanpm = $INC{'CPAN/MyConfig.pm'} ||
1650         File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm");
1651     File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm;
1652     CPAN::HandleConfig::require_myconfig_or_config;
1653     $CPAN::Config ||= {};
1654     $CPAN::Config = {
1655         %$CPAN::Config,
1656         build_dir           =>  undef,
1657         cpan_home           =>  undef,
1658         keep_source_where   =>  undef,
1659         histfile            =>  undef,
1660     };
1661     CPAN::FirstTime::init($cpanpm, %args);
1662 }
1663
1664 #-> sub CPAN::Shell::_binary_extensions ;
1665 sub _binary_extensions {
1666     my($self) = shift @_;
1667     my(@result,$module,%seen,%need,$headerdone);
1668     for $module ($self->expand('Module','/./')) {
1669         my $file  = $module->cpan_file;
1670         next if $file eq "N/A";
1671         next if $file =~ /^Contact Author/;
1672         my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
1673         next if $dist->isa_perl;
1674         next unless $module->xs_file;
1675         local($|) = 1;
1676         $CPAN::Frontend->myprint(".");
1677         push @result, $module;
1678     }
1679 #    print join " | ", @result;
1680     $CPAN::Frontend->myprint("\n");
1681     return @result;
1682 }
1683
1684 #-> sub CPAN::Shell::recompile ;
1685 sub recompile {
1686     my($self) = shift @_;
1687     my($module,@module,$cpan_file,%dist);
1688     @module = $self->_binary_extensions();
1689     for $module (@module){  # we force now and compile later, so we
1690                             # don't do it twice
1691         $cpan_file = $module->cpan_file;
1692         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1693         $pack->force;
1694         $dist{$cpan_file}++;
1695     }
1696     for $cpan_file (sort keys %dist) {
1697         $CPAN::Frontend->myprint("  CPAN: Recompiling $cpan_file\n\n");
1698         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1699         $pack->install;
1700         $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1701                            # stop a package from recompiling,
1702                            # e.g. IO-1.12 when we have perl5.003_10
1703     }
1704 }
1705
1706 #-> sub CPAN::Shell::scripts ;
1707 sub scripts {
1708     my($self, $arg) = @_;
1709     $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");
1710
1711     for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) {
1712         unless ($CPAN::META->has_inst($req)) {
1713             $CPAN::Frontend->mywarn("  $req not available\n");
1714         }
1715     }
1716     my $p = HTML::LinkExtor->new();
1717     my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html";
1718     unless (-f $indexfile) {
1719         $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n");
1720     }
1721     $p->parse_file($indexfile);
1722     my @hrefs;
1723     my $qrarg;
1724     if ($arg =~ s|^/(.+)/$|$1|) {
1725         $qrarg = eval 'qr/$arg/'; # hide construct from 5.004
1726     }
1727     for my $l ($p->links) {
1728         my $tag = shift @$l;
1729         next unless $tag eq "a";
1730         my %att = @$l;
1731         my $href = $att{href};
1732         next unless $href =~ s|^\.\./authors/id/./../||;
1733         if ($arg) {
1734             if ($qrarg) {
1735                 if ($href =~ $qrarg) {
1736                     push @hrefs, $href;
1737                 }
1738             } else {
1739                 if ($href =~ /\Q$arg\E/) {
1740                     push @hrefs, $href;
1741                 }
1742             }
1743         } else {
1744             push @hrefs, $href;
1745         }
1746     }
1747     # now filter for the latest version if there is more than one of a name
1748     my %stems;
1749     for (sort @hrefs) {
1750         my $href = $_;
1751         s/-v?\d.*//;
1752         my $stem = $_;
1753         $stems{$stem} ||= [];
1754         push @{$stems{$stem}}, $href;
1755     }
1756     for (sort keys %stems) {
1757         my $highest;
1758         if (@{$stems{$_}} > 1) {
1759             $highest = List::Util::reduce {
1760                 Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b
1761               } @{$stems{$_}};
1762         } else {
1763             $highest = $stems{$_}[0];
1764         }
1765         $CPAN::Frontend->myprint("$highest\n");
1766     }
1767 }
1768
1769 #-> sub CPAN::Shell::upgrade ;
1770 sub upgrade {
1771     my($self) = shift @_;
1772     $self->install($self->r);
1773 }
1774
1775 #-> sub CPAN::Shell::_u_r_common ;
1776 sub _u_r_common {
1777     my($self) = shift @_;
1778     my($what) = shift @_;
1779     CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
1780     Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
1781           $what && $what =~ /^[aru]$/;
1782     my(@args) = @_;
1783     @args = '/./' unless @args;
1784     my(@result,$module,%seen,%need,$headerdone,
1785        $version_undefs,$version_zeroes);
1786     $version_undefs = $version_zeroes = 0;
1787     my $sprintf = "%s%-25s%s %9s %9s  %s\n";
1788     my @expand = $self->expand('Module',@args);
1789     my $expand = scalar @expand;
1790     if (0) { # Looks like noise to me, was very useful for debugging
1791              # for metadata cache
1792         $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
1793     }
1794   MODULE: for $module (@expand) {
1795         my $file  = $module->cpan_file;
1796         next MODULE unless defined $file; # ??
1797         $file =~ s|^./../||;
1798         my($latest) = $module->cpan_version;
1799         my($inst_file) = $module->inst_file;
1800         my($have);
1801         return if $CPAN::Signal;
1802         if ($inst_file){
1803             if ($what eq "a") {
1804                 $have = $module->inst_version;
1805             } elsif ($what eq "r") {
1806                 $have = $module->inst_version;
1807                 local($^W) = 0;
1808                 if ($have eq "undef"){
1809                     $version_undefs++;
1810                 } elsif ($have == 0){
1811                     $version_zeroes++;
1812                 }
1813                 next MODULE unless CPAN::Version->vgt($latest, $have);
1814 # to be pedantic we should probably say:
1815 #    && !($have eq "undef" && $latest ne "undef" && $latest gt "");
1816 # to catch the case where CPAN has a version 0 and we have a version undef
1817             } elsif ($what eq "u") {
1818                 next MODULE;
1819             }
1820         } else {
1821             if ($what eq "a") {
1822                 next MODULE;
1823             } elsif ($what eq "r") {
1824                 next MODULE;
1825             } elsif ($what eq "u") {
1826                 $have = "-";
1827             }
1828         }
1829         return if $CPAN::Signal; # this is sometimes lengthy
1830         $seen{$file} ||= 0;
1831         if ($what eq "a") {
1832             push @result, sprintf "%s %s\n", $module->id, $have;
1833         } elsif ($what eq "r") {
1834             push @result, $module->id;
1835             next MODULE if $seen{$file}++;
1836         } elsif ($what eq "u") {
1837             push @result, $module->id;
1838             next MODULE if $seen{$file}++;
1839             next MODULE if $file =~ /^Contact/;
1840         }
1841         unless ($headerdone++){
1842             $CPAN::Frontend->myprint("\n");
1843             $CPAN::Frontend->myprint(sprintf(
1844                                              $sprintf,
1845                                              "",
1846                                              "Package namespace",
1847                                              "",
1848                                              "installed",
1849                                              "latest",
1850                                              "in CPAN file"
1851                                             ));
1852         }
1853         my $color_on = "";
1854         my $color_off = "";
1855         if (
1856             $COLOR_REGISTERED
1857             &&
1858             $CPAN::META->has_inst("Term::ANSIColor")
1859             &&
1860             $module->description
1861            ) {
1862             $color_on = Term::ANSIColor::color("green");
1863             $color_off = Term::ANSIColor::color("reset");
1864         }
1865         $CPAN::Frontend->myprint(sprintf $sprintf,
1866                                  $color_on,
1867                                  $module->id,
1868                                  $color_off,
1869                                  $have,
1870                                  $latest,
1871                                  $file);
1872         $need{$module->id}++;
1873     }
1874     unless (%need) {
1875         if ($what eq "u") {
1876             $CPAN::Frontend->myprint("No modules found for @args\n");
1877         } elsif ($what eq "r") {
1878             $CPAN::Frontend->myprint("All modules are up to date for @args\n");
1879         }
1880     }
1881     if ($what eq "r") {
1882         if ($version_zeroes) {
1883             my $s_has = $version_zeroes > 1 ? "s have" : " has";
1884             $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
1885                 qq{a version number of 0\n});
1886         }
1887         if ($version_undefs) {
1888             my $s_has = $version_undefs > 1 ? "s have" : " has";
1889             $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
1890                 qq{parseable version number\n});
1891         }
1892     }
1893     @result;
1894 }
1895
1896 #-> sub CPAN::Shell::r ;
1897 sub r {
1898     shift->_u_r_common("r",@_);
1899 }
1900
1901 #-> sub CPAN::Shell::u ;
1902 sub u {
1903     shift->_u_r_common("u",@_);
1904 }
1905
1906 #-> sub CPAN::Shell::failed ;
1907 sub failed {
1908     my($self,$only_id,$silent) = @_;
1909     my @failed;
1910   DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
1911         my $failed = "";
1912       NAY: for my $nosayer (
1913                             "writemakefile",
1914                             "signature_verify",
1915                             "make",
1916                             "make_test",
1917                             "install",
1918                             "make_clean",
1919                            ) {
1920             next unless exists $d->{$nosayer};
1921             next unless (
1922                          $d->{$nosayer}->can("failed") ?
1923                          $d->{$nosayer}->failed :
1924                          $d->{$nosayer} =~ /^NO/
1925                         );
1926             next NAY if $only_id && $only_id != (
1927                                                  $d->{$nosayer}->can("commandid")
1928                                                  ?
1929                                                  $d->{$nosayer}->commandid
1930                                                  :
1931                                                  $CPAN::CurrentCommandId
1932                                                 );
1933             $failed = $nosayer;
1934             last;
1935         }
1936         next DIST unless $failed;
1937         my $id = $d->id;
1938         $id =~ s|^./../||;
1939         #$print .= sprintf(
1940         #                  "  %-45s: %s %s\n",
1941         push @failed,
1942             (
1943              $d->{$failed}->can("failed") ?
1944              [
1945               $d->{$failed}->commandid,
1946               $id,
1947               $failed,
1948               $d->{$failed}->text,
1949              ] :
1950              [
1951               1,
1952               $id,
1953               $failed,
1954               $d->{$failed},
1955              ]
1956             );
1957     }
1958     my $scope = $only_id ? "command" : "session";
1959     if (@failed) {
1960         my $print = join "",
1961             map { sprintf "  %-45s: %s %s\n", @$_[1,2,3] }
1962                 sort { $a->[0] <=> $b->[0] } @failed;
1963         $CPAN::Frontend->myprint("Failed during this $scope:\n$print");
1964     } elsif (!$only_id || !$silent) {
1965         $CPAN::Frontend->myprint("Nothing failed in this $scope\n");
1966     }
1967 }
1968
1969 # XXX intentionally undocumented because completely bogus, unportable,
1970 # useless, etc.
1971
1972 #-> sub CPAN::Shell::status ;
1973 sub status {
1974     my($self) = @_;
1975     require Devel::Size;
1976     my $ps = FileHandle->new;
1977     open $ps, "/proc/$$/status";
1978     my $vm = 0;
1979     while (<$ps>) {
1980         next unless /VmSize:\s+(\d+)/;
1981         $vm = $1;
1982         last;
1983     }
1984     $CPAN::Frontend->mywarn(sprintf(
1985                                     "%-27s %6d\n%-27s %6d\n",
1986                                     "vm",
1987                                     $vm,
1988                                     "CPAN::META",
1989                                     Devel::Size::total_size($CPAN::META)/1024,
1990                                    ));
1991     for my $k (sort keys %$CPAN::META) {
1992         next unless substr($k,0,4) eq "read";
1993         warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
1994         for my $k2 (sort keys %{$CPAN::META->{$k}}) {
1995             warn sprintf "  %-25s %6d %6d\n",
1996                 $k2,
1997                     Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
1998                           scalar keys %{$CPAN::META->{$k}{$k2}};
1999         }
2000     }
2001 }
2002
2003 #-> sub CPAN::Shell::autobundle ;
2004 sub autobundle {
2005     my($self) = shift;
2006     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
2007     my(@bundle) = $self->_u_r_common("a",@_);
2008     my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
2009     File::Path::mkpath($todir);
2010     unless (-d $todir) {
2011         $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
2012         return;
2013     }
2014     my($y,$m,$d) =  (localtime)[5,4,3];
2015     $y+=1900;
2016     $m++;
2017     my($c) = 0;
2018     my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
2019     my($to) = File::Spec->catfile($todir,"$me.pm");
2020     while (-f $to) {
2021         $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
2022         $to = File::Spec->catfile($todir,"$me.pm");
2023     }
2024     my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
2025     $fh->print(
2026                "package Bundle::$me;\n\n",
2027                "\$VERSION = '0.01';\n\n",
2028                "1;\n\n",
2029                "__END__\n\n",
2030                "=head1 NAME\n\n",
2031                "Bundle::$me - Snapshot of installation on ",
2032                $Config::Config{'myhostname'},
2033                " on ",
2034                scalar(localtime),
2035                "\n\n=head1 SYNOPSIS\n\n",
2036                "perl -MCPAN -e 'install Bundle::$me'\n\n",
2037                "=head1 CONTENTS\n\n",
2038                join("\n", @bundle),
2039                "\n\n=head1 CONFIGURATION\n\n",
2040                Config->myconfig,
2041                "\n\n=head1 AUTHOR\n\n",
2042                "This Bundle has been generated automatically ",
2043                "by the autobundle routine in CPAN.pm.\n",
2044               );
2045     $fh->close;
2046     $CPAN::Frontend->myprint("\nWrote bundle file
2047     $to\n\n");
2048 }
2049
2050 #-> sub CPAN::Shell::expandany ;
2051 sub expandany {
2052     my($self,$s) = @_;
2053     CPAN->debug("s[$s]") if $CPAN::DEBUG;
2054     if ($s =~ m|/|) { # looks like a file
2055         $s = CPAN::Distribution->normalize($s);
2056         return $CPAN::META->instance('CPAN::Distribution',$s);
2057         # Distributions spring into existence, not expand
2058     } elsif ($s =~ m|^Bundle::|) {
2059         $self->local_bundles; # scanning so late for bundles seems
2060                               # both attractive and crumpy: always
2061                               # current state but easy to forget
2062                               # somewhere
2063         return $self->expand('Bundle',$s);
2064     } else {
2065         return $self->expand('Module',$s)
2066             if $CPAN::META->exists('CPAN::Module',$s);
2067     }
2068     return;
2069 }
2070
2071 #-> sub CPAN::Shell::expand ;
2072 sub expand {
2073     my $self = shift;
2074     my($type,@args) = @_;
2075     CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
2076     my $class = "CPAN::$type";
2077     my $methods = ['id'];
2078     for my $meth (qw(name)) {
2079         next if $] < 5.00303; # no "can"
2080         next unless $class->can($meth);
2081         push @$methods, $meth;
2082     }
2083     $self->expand_by_method($class,$methods,@args);
2084 }
2085
2086 sub expand_by_method {
2087     my $self = shift;
2088     my($class,$methods,@args) = @_;
2089     my($arg,@m);
2090     for $arg (@args) {
2091         my($regex,$command);
2092         if ($arg =~ m|^/(.*)/$|) {
2093             $regex = $1;
2094         } elsif ($arg =~ m/=/) {
2095             $command = 1;
2096         }
2097         my $obj;
2098         CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
2099                     $class,
2100                     defined $regex ? $regex : "UNDEFINED",
2101                     defined $command ? $command : "UNDEFINED",
2102                    ) if $CPAN::DEBUG;
2103         if (defined $regex) {
2104             for $obj (
2105                       $CPAN::META->all_objects($class)
2106                      ) {
2107                 unless ($obj->id){
2108                     # BUG, we got an empty object somewhere
2109                     require Data::Dumper;
2110                     CPAN->debug(sprintf(
2111                                         "Bug in CPAN: Empty id on obj[%s][%s]",
2112                                         $obj,
2113                                         Data::Dumper::Dumper($obj)
2114                                        )) if $CPAN::DEBUG;
2115                     next;
2116                 }
2117                 for my $method (@$methods) {
2118                     if ($obj->$method() =~ /$regex/i) {
2119                         push @m, $obj;
2120                         last;
2121                     }
2122                 }
2123             }
2124         } elsif ($command) {
2125             die "equal sign in command disabled (immature interface), ".
2126                 "you can set
2127  ! \$CPAN::Shell::ADVANCED_QUERY=1
2128 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
2129 that may go away anytime.\n"
2130                     unless $ADVANCED_QUERY;
2131             my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
2132             my($matchcrit) = $criterion =~ m/^~(.+)/;
2133             for my $self (
2134                           sort
2135                           {$a->id cmp $b->id}
2136                           $CPAN::META->all_objects($class)
2137                          ) {
2138                 my $lhs = $self->$method() or next; # () for 5.00503
2139                 if ($matchcrit) {
2140                     push @m, $self if $lhs =~ m/$matchcrit/;
2141                 } else {
2142                     push @m, $self if $lhs eq $criterion;
2143                 }
2144             }
2145         } else {
2146             my($xarg) = $arg;
2147             if ( $class eq 'CPAN::Bundle' ) {
2148                 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
2149             } elsif ($class eq "CPAN::Distribution") {
2150                 $xarg = CPAN::Distribution->normalize($arg);
2151             } else {
2152                 $xarg =~ s/:+/::/g;
2153             }
2154             if ($CPAN::META->exists($class,$xarg)) {
2155                 $obj = $CPAN::META->instance($class,$xarg);
2156             } elsif ($CPAN::META->exists($class,$arg)) {
2157                 $obj = $CPAN::META->instance($class,$arg);
2158             } else {
2159                 next;
2160             }
2161             push @m, $obj;
2162         }
2163     }
2164     @m = sort {$a->id cmp $b->id} @m;
2165     if ( $CPAN::DEBUG ) {
2166         my $wantarray = wantarray;
2167         my $join_m = join ",", map {$_->id} @m;
2168         $self->debug("wantarray[$wantarray]join_m[$join_m]");
2169     }
2170     return wantarray ? @m : $m[0];
2171 }
2172
2173 #-> sub CPAN::Shell::format_result ;
2174 sub format_result {
2175     my($self) = shift;
2176     my($type,@args) = @_;
2177     @args = '/./' unless @args;
2178     my(@result) = $self->expand($type,@args);
2179     my $result = @result == 1 ?
2180         $result[0]->as_string :
2181             @result == 0 ?
2182                 "No objects of type $type found for argument @args\n" :
2183                     join("",
2184                          (map {$_->as_glimpse} @result),
2185                          scalar @result, " items found\n",
2186                         );
2187     $result;
2188 }
2189
2190 #-> sub CPAN::Shell::report_fh ;
2191 {
2192     my $installation_report_fh;
2193     my $previously_noticed = 0;
2194
2195     sub report_fh {
2196         return $installation_report_fh if $installation_report_fh;
2197         if ($CPAN::META->has_inst("File::Temp")) {
2198             $installation_report_fh
2199                 = File::Temp->new(
2200                                   template => 'cpan_install_XXXX',
2201                                   suffix   => '.txt',
2202                                   unlink   => 0,
2203                                  );
2204         }
2205         unless ( $installation_report_fh ) {
2206             warn("Couldn't open installation report file; " .
2207                  "no report file will be generated."
2208                 ) unless $previously_noticed++;
2209         }
2210     }
2211 }
2212
2213
2214 # The only reason for this method is currently to have a reliable
2215 # debugging utility that reveals which output is going through which
2216 # channel. No, I don't like the colors ;-)
2217
2218 # to turn colordebugging on, write
2219 # cpan> o conf colorize_output 1
2220
2221 #-> sub CPAN::Shell::print_ornamented ;
2222 {
2223     my $print_ornamented_have_warned = 0;
2224     sub colorize_output {
2225         my $colorize_output = $CPAN::Config->{colorize_output};
2226         if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
2227             unless ($print_ornamented_have_warned++) {
2228                 # no myprint/mywarn within myprint/mywarn!
2229                 warn "Colorize_output is set to true but Term::ANSIColor is not
2230 installed. To activate colorized output, please install Term::ANSIColor.\n\n";
2231             }
2232             $colorize_output = 0;
2233         }
2234         return $colorize_output;
2235     }
2236 }
2237
2238
2239 sub print_ornamented {
2240     my($self,$what,$ornament) = @_;
2241     return unless defined $what;
2242
2243     local $| = 1; # Flush immediately
2244     if ( $CPAN::Be_Silent ) {
2245         print {report_fh()} $what;
2246         return;
2247     }
2248     my $swhat = "$what"; # stringify if it is an object
2249     if ($CPAN::Config->{term_is_latin}){
2250         # courtesy jhi:
2251         $swhat
2252             =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
2253     }
2254     my $line;
2255     my $longest = 0; # Does list::util work on 5.004?
2256     for $line (split /\n/, $swhat) {
2257         $longest = length($line) if length($line) > $longest;
2258     }
2259     $longest = 78 if $longest > 78; # yes, arbitrary, who wants it set-able?
2260     if ($self->colorize_output) {
2261         my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
2262         if ($@) {
2263             print "Term::ANSIColor rejects color[$ornament]: $@\n
2264 Please choose a different color (Hint: try 'o conf init color.*')\n";
2265         }
2266         my $demobug = 0; # (=0) works, (=1) has some obscure bugs and
2267                          # breaks 30shell.t, (=2) has some obvious
2268                          # bugs but passes 30shell.t
2269         if ($demobug == 1) {
2270             my $nl = chomp $swhat ? "\n" : "";
2271             while (length $swhat) {
2272                 $line = "";
2273                 if (0) {
2274                     $swhat =~ s/(.*\n?)//m;
2275                     $line = $1;
2276                     last unless $line;
2277                 } else {
2278                     while (length $swhat) {
2279                         my $c = substr($swhat,0,1);
2280                         $swhat = substr($swhat,1);
2281                         $line .= $c;
2282                         if ($c eq "\n") {
2283                             last;
2284                         }
2285                     }
2286                 }
2287
2288                 # my($nl) = chomp $line ? "\n" : "";
2289                 # ->debug verboten within print_ornamented ==> recursion!
2290                 # warn("line[$line]ornament[$ornament]sprintf[$sprintf]\n") if $CPAN::DEBUG;
2291                 print $color_on,
2292                     sprintf("%-*s",$longest,$line),
2293                         Term::ANSIColor::color("reset"),
2294                               $line =~ /\n/ ? "" : $nl;
2295             }
2296         } elsif ($demobug == 2) {
2297             my $block = join "\n",
2298                 map {
2299                     sprintf("%s%-*s%s",
2300                             $color_on,
2301                             $longest,
2302                             $_,
2303                             Term::ANSIColor::color("reset"),
2304                            )
2305                 }
2306                     split /[\r ]*\n/, $swhat;
2307             print $block;
2308         } else {
2309             print $color_on,
2310                 $swhat,
2311                     Term::ANSIColor::color("reset");
2312         }
2313     } else {
2314         print $swhat;
2315     }
2316 }
2317
2318 # where is myprint/mywarn/Frontend/etc. documented? We need guidelines
2319 # where to use what! I think, we send everything to STDOUT and use
2320 # print for normal/good news and warn for news that need more
2321 # attention. Yes, this is our working contract for now.
2322 sub myprint {
2323     my($self,$what) = @_;
2324
2325     $self->print_ornamented($what, $CPAN::Config->{colorize_print}||'bold blue');
2326 }
2327
2328 sub myexit {
2329     my($self,$what) = @_;
2330     $self->myprint($what);
2331     exit;
2332 }
2333
2334 sub mywarn {
2335     my($self,$what) = @_;
2336     $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red');
2337 }
2338
2339 # only to be used for shell commands
2340 sub mydie {
2341     my($self,$what) = @_;
2342     $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red');
2343
2344     # If it is the shell, we want that the following die to be silent,
2345     # but if it is not the shell, we would need a 'die $what'. We need
2346     # to take care that only shell commands use mydie. Is this
2347     # possible?
2348
2349     die "\n";
2350 }
2351
2352 # sub CPAN::Shell::colorable_makemaker_prompt
2353 sub colorable_makemaker_prompt {
2354     my($foo,$bar) = @_;
2355     if (CPAN::Shell->colorize_output) {
2356         my $ornament = $CPAN::Config->{colorize_print}||'bold blue';
2357         my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
2358         print $color_on;
2359     }
2360     my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
2361     if (CPAN::Shell->colorize_output) {
2362         print Term::ANSIColor::color('reset');
2363     }
2364     return $ans;
2365 }
2366
2367 # use this only for unrecoverable errors!
2368 sub unrecoverable_error {
2369     my($self,$what) = @_;
2370     my @lines = split /\n/, $what;
2371     my $longest = 0;
2372     for my $l (@lines) {
2373         $longest = length $l if length $l > $longest;
2374     }
2375     $longest = 62 if $longest > 62;
2376     for my $l (@lines) {
2377         if ($l =~ /^\s*$/){
2378             $l = "\n";
2379             next;
2380         }
2381         $l = "==> $l";
2382         if (length $l < 66) {
2383             $l = pack "A66 A*", $l, "<==";
2384         }
2385         $l .= "\n";
2386     }
2387     unshift @lines, "\n";
2388     $self->mydie(join "", @lines);
2389 }
2390
2391 sub mysleep {
2392     my($self, $sleep) = @_;
2393     sleep $sleep;
2394 }
2395
2396 sub setup_output {
2397     return if -t STDOUT;
2398     my $odef = select STDERR;
2399     $| = 1;
2400     select STDOUT;
2401     $| = 1;
2402     select $odef;
2403 }
2404
2405 #-> sub CPAN::Shell::rematein ;
2406 # RE-adme||MA-ke||TE-st||IN-stall
2407 sub rematein {
2408     my $self = shift;
2409     my($meth,@some) = @_;
2410     my @pragma;
2411     while($meth =~ /^(force|notest)$/) {
2412         push @pragma, $meth;
2413         $meth = shift @some or
2414             $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
2415                                    "cannot continue");
2416     }
2417     setup_output();
2418     CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
2419
2420     # Here is the place to set "test_count" on all involved parties to
2421     # 0. We then can pass this counter on to the involved
2422     # distributions and those can refuse to test if test_count > X. In
2423     # the first stab at it we could use a 1 for "X".
2424
2425     # But when do I reset the distributions to start with 0 again?
2426     # Jost suggested to have a random or cycling interaction ID that
2427     # we pass through. But the ID is something that is just left lying
2428     # around in addition to the counter, so I'd prefer to set the
2429     # counter to 0 now, and repeat at the end of the loop. But what
2430     # about dependencies? They appear later and are not reset, they
2431     # enter the queue but not its copy. How do they get a sensible
2432     # test_count?
2433
2434     # construct the queue
2435     my($s,@s,@qcopy);
2436   STHING: foreach $s (@some) {
2437         my $obj;
2438         if (ref $s) {
2439             CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
2440             $obj = $s;
2441         } elsif ($s =~ m|^/|) { # looks like a regexp
2442             $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
2443                                     "not supported\n");
2444             $CPAN::Frontend->mysleep(2);
2445             next;
2446         } elsif ($meth eq "ls") {
2447             $self->globls($s,\@pragma);
2448             next STHING;
2449         } else {
2450             CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
2451             $obj = CPAN::Shell->expandany($s);
2452         }
2453         if (ref $obj) {
2454             $obj->color_cmd_tmps(0,1);
2455             CPAN::Queue->new($obj->id);
2456             push @qcopy, $obj;
2457         } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
2458             $obj = $CPAN::META->instance('CPAN::Author',uc($s));
2459             if ($meth =~ /^(dump|ls)$/) {
2460                 $obj->$meth();
2461             } else {
2462                 $CPAN::Frontend->mywarn(
2463                                         join "",
2464                                         "Don't be silly, you can't $meth ",
2465                                         $obj->fullname,
2466                                         " ;-)\n"
2467                                        );
2468                 $CPAN::Frontend->mysleep(2);
2469             }
2470         } else {
2471             $CPAN::Frontend
2472                 ->mywarn(qq{Warning: Cannot $meth $s, }.
2473                           qq{don\'t know what it is.
2474 Try the command
2475
2476     i /$s/
2477
2478 to find objects with matching identifiers.
2479 });
2480             $CPAN::Frontend->mysleep(2);
2481         }
2482     }
2483
2484     # queuerunner (please be warned: when I started to change the
2485     # queue to hold objects instead of names, I made one or two
2486     # mistakes and never found which. I reverted back instead)
2487     while ($s = CPAN::Queue->first) {
2488         my $obj;
2489         if (ref $s) {
2490             $obj = $s; # I do not believe, we would survive if this happened
2491         } else {
2492             $obj = CPAN::Shell->expandany($s);
2493         }
2494         for my $pragma (@pragma) {
2495             if ($pragma
2496                 &&
2497                 ($] < 5.00303 || $obj->can($pragma))){
2498                 ### compatibility with 5.003
2499                 $obj->$pragma($meth); # the pragma "force" in
2500                                       # "CPAN::Distribution" must know
2501                                       # what we are intending
2502             }
2503         }
2504         if ($]>=5.00303 && $obj->can('called_for')) {
2505             $obj->called_for($s);
2506         }
2507         CPAN->debug(
2508                     qq{pragma[@pragma]meth[$meth]obj[$obj]as_string[$obj->{ID}]}
2509                    ) if $CPAN::DEBUG;
2510
2511         if ($obj->$meth()){
2512             CPAN::Queue->delete($s);
2513         } else {
2514             CPAN->debug("failed");
2515         }
2516
2517         $obj->undelay;
2518         CPAN::Queue->delete_first($s);
2519     }
2520     for my $obj (@qcopy) {
2521         $obj->color_cmd_tmps(0,0);
2522         delete $obj->{incommandcolor};
2523     }
2524 }
2525
2526 #-> sub CPAN::Shell::recent ;
2527 sub recent {
2528   my($self) = @_;
2529
2530   CPAN::Distribution::_display_url( $self, $CPAN::Defaultrecent );
2531   return;
2532 }
2533
2534 {
2535     # set up the dispatching methods
2536     no strict "refs";
2537     for my $command (qw(
2538                         clean
2539                         cvs_import
2540                         dump
2541                         force
2542                         get
2543                         install
2544                         look
2545                         ls
2546                         make
2547                         notest
2548                         perldoc
2549                         readme
2550                         test
2551                        )) {
2552         *$command = sub { shift->rematein($command, @_); };
2553     }
2554 }
2555
2556 package CPAN::LWP::UserAgent;
2557 use strict;
2558
2559 sub config {
2560     return if $SETUPDONE;
2561     if ($CPAN::META->has_usable('LWP::UserAgent')) {
2562         require LWP::UserAgent;
2563         @ISA = qw(Exporter LWP::UserAgent);
2564         $SETUPDONE++;
2565     } else {
2566         $CPAN::Frontend->mywarn("  LWP::UserAgent not available\n");
2567     }
2568 }
2569
2570 sub get_basic_credentials {
2571     my($self, $realm, $uri, $proxy) = @_;
2572     if ($USER && $PASSWD) {
2573         return ($USER, $PASSWD);
2574     }
2575     if ( $proxy ) {
2576         ($USER,$PASSWD) = $self->get_proxy_credentials();
2577     } else {
2578         ($USER,$PASSWD) = $self->get_non_proxy_credentials();
2579     }
2580     return($USER,$PASSWD);
2581 }
2582
2583 sub get_proxy_credentials {
2584     my $self = shift;
2585     my ($user, $password);
2586     if ( defined $CPAN::Config->{proxy_user} &&
2587          defined $CPAN::Config->{proxy_pass}) {
2588         $user = $CPAN::Config->{proxy_user};
2589         $password = $CPAN::Config->{proxy_pass};
2590         return ($user, $password);
2591     }
2592     my $username_prompt = "\nProxy authentication needed!
2593  (Note: to permanently configure username and password run
2594    o conf proxy_user your_username
2595    o conf proxy_pass your_password
2596      )\nUsername:";
2597     ($user, $password) =
2598         _get_username_and_password_from_user($username_prompt);
2599     return ($user,$password);
2600 }
2601
2602 sub get_non_proxy_credentials {
2603     my $self = shift;
2604     my ($user,$password);
2605     if ( defined $CPAN::Config->{username} &&
2606          defined $CPAN::Config->{password}) {
2607         $user = $CPAN::Config->{username};
2608         $password = $CPAN::Config->{password};
2609         return ($user, $password);
2610     }
2611     my $username_prompt = "\nAuthentication needed!
2612      (Note: to permanently configure username and password run
2613        o conf username your_username
2614        o conf password your_password
2615      )\nUsername:";
2616
2617     ($user, $password) =
2618         _get_username_and_password_from_user($username_prompt);
2619     return ($user,$password);
2620 }
2621
2622 sub _get_username_and_password_from_user {
2623     my $self = shift;
2624     my $username_message = shift;
2625     my ($username,$password);
2626
2627     ExtUtils::MakeMaker->import(qw(prompt));
2628     $username = prompt($username_message);
2629         if ($CPAN::META->has_inst("Term::ReadKey")) {
2630             Term::ReadKey::ReadMode("noecho");
2631         }
2632     else {
2633         $CPAN::Frontend->mywarn(
2634             "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"
2635         );
2636     }
2637     $password = prompt("Password:");
2638
2639         if ($CPAN::META->has_inst("Term::ReadKey")) {
2640             Term::ReadKey::ReadMode("restore");
2641         }
2642         $CPAN::Frontend->myprint("\n\n");
2643     return ($username,$password);
2644 }
2645
2646 # mirror(): Its purpose is to deal with proxy authentication. When we
2647 # call SUPER::mirror, we relly call the mirror method in
2648 # LWP::UserAgent. LWP::UserAgent will then call
2649 # $self->get_basic_credentials or some equivalent and this will be
2650 # $self->dispatched to our own get_basic_credentials method.
2651
2652 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
2653
2654 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
2655 # although we have gone through our get_basic_credentials, the proxy
2656 # server refuses to connect. This could be a case where the username or
2657 # password has changed in the meantime, so I'm trying once again without
2658 # $USER and $PASSWD to give the get_basic_credentials routine another
2659 # chance to set $USER and $PASSWD.
2660
2661 # mirror(): Its purpose is to deal with proxy authentication. When we
2662 # call SUPER::mirror, we relly call the mirror method in
2663 # LWP::UserAgent. LWP::UserAgent will then call
2664 # $self->get_basic_credentials or some equivalent and this will be
2665 # $self->dispatched to our own get_basic_credentials method.
2666
2667 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
2668
2669 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
2670 # although we have gone through our get_basic_credentials, the proxy
2671 # server refuses to connect. This could be a case where the username or
2672 # password has changed in the meantime, so I'm trying once again without
2673 # $USER and $PASSWD to give the get_basic_credentials routine another
2674 # chance to set $USER and $PASSWD.
2675
2676 sub mirror {
2677     my($self,$url,$aslocal) = @_;
2678     my $result = $self->SUPER::mirror($url,$aslocal);
2679     if ($result->code == 407) {
2680         undef $USER;
2681         undef $PASSWD;
2682         $result = $self->SUPER::mirror($url,$aslocal);
2683     }
2684     $result;
2685 }
2686
2687 package CPAN::FTP;
2688 use strict;
2689
2690 #-> sub CPAN::FTP::ftp_get ;
2691 sub ftp_get {
2692     my($class,$host,$dir,$file,$target) = @_;
2693     $class->debug(
2694                   qq[Going to fetch file [$file] from dir [$dir]
2695         on host [$host] as local [$target]\n]
2696                  ) if $CPAN::DEBUG;
2697     my $ftp = Net::FTP->new($host);
2698     unless ($ftp) {
2699         $CPAN::Frontend->mywarn("  Could not connect to host '$host' with Net::FTP\n");
2700         return;
2701     }
2702     return 0 unless defined $ftp;
2703     $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
2704     $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
2705     unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
2706         my $msg = $ftp->message;
2707         $CPAN::Frontend->mywarn("  Couldn't login on $host: $msg");
2708         return;
2709     }
2710     unless ( $ftp->cwd($dir) ){
2711         my $msg = $ftp->message;
2712         $CPAN::Frontend->mywarn("  Couldn't cwd $dir: $msg");
2713         return;
2714     }
2715     $ftp->binary;
2716     $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
2717     unless ( $ftp->get($file,$target) ){
2718         my $msg = $ftp->message;
2719         $CPAN::Frontend->mywarn("  Couldn't fetch $file from $host: $msg");
2720         return;
2721     }
2722     $ftp->quit; # it's ok if this fails
2723     return 1;
2724 }
2725
2726 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
2727
2728  # > *** /install/perl/live/lib/CPAN.pm-        Wed Sep 24 13:08:48 1997
2729  # > --- /tmp/cp        Wed Sep 24 13:26:40 1997
2730  # > ***************
2731  # > *** 1562,1567 ****
2732  # > --- 1562,1580 ----
2733  # >       return 1 if substr($url,0,4) eq "file";
2734  # >       return 1 unless $url =~ m|://([^/]+)|;
2735  # >       my $host = $1;
2736  # > +     my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
2737  # > +     if ($proxy) {
2738  # > +         $proxy =~ m|://([^/:]+)|;
2739  # > +         $proxy = $1;
2740  # > +         my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
2741  # > +         if ($noproxy) {
2742  # > +             if ($host !~ /$noproxy$/) {
2743  # > +                 $host = $proxy;
2744  # > +             }
2745  # > +         } else {
2746  # > +             $host = $proxy;
2747  # > +         }
2748  # > +     }
2749  # >       require Net::Ping;
2750  # >       return 1 unless $Net::Ping::VERSION >= 2;
2751  # >       my $p;
2752
2753
2754 #-> sub CPAN::FTP::localize ;
2755 sub localize {
2756     my($self,$file,$aslocal,$force) = @_;
2757     $force ||= 0;
2758     Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
2759         unless defined $aslocal;
2760     $self->debug("file[$file] aslocal[$aslocal] force[$force]")
2761         if $CPAN::DEBUG;
2762
2763     if ($^O eq 'MacOS') {
2764         # Comment by AK on 2000-09-03: Uniq short filenames would be
2765         # available in CHECKSUMS file
2766         my($name, $path) = File::Basename::fileparse($aslocal, '');
2767         if (length($name) > 31) {
2768             $name =~ s/(
2769                         \.(
2770                            readme(\.(gz|Z))? |
2771                            (tar\.)?(gz|Z) |
2772                            tgz |
2773                            zip |
2774                            pm\.(gz|Z)
2775                           )
2776                        )$//x;
2777             my $suf = $1;
2778             my $size = 31 - length($suf);
2779             while (length($name) > $size) {
2780                 chop $name;
2781             }
2782             $name .= $suf;
2783             $aslocal = File::Spec->catfile($path, $name);
2784         }
2785     }
2786
2787     if (-f $aslocal && -r _ && !($force & 1)){
2788         my $size;
2789         if ($size = -s $aslocal) {
2790             $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
2791             return $aslocal;
2792         } else {
2793             # empty file from a previous unsuccessful attempt to download it
2794             unlink $aslocal or
2795                 $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
2796                                        "could not remove.");
2797         }
2798     }
2799     my($restore) = 0;
2800     if (-f $aslocal){
2801         rename $aslocal, "$aslocal.bak";
2802         $restore++;
2803     }
2804
2805     my($aslocal_dir) = File::Basename::dirname($aslocal);
2806     File::Path::mkpath($aslocal_dir);
2807     $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
2808         qq{directory "$aslocal_dir".
2809     I\'ll continue, but if you encounter problems, they may be due
2810     to insufficient permissions.\n}) unless -w $aslocal_dir;
2811
2812     # Inheritance is not easier to manage than a few if/else branches
2813     if ($CPAN::META->has_usable('LWP::UserAgent')) {
2814         unless ($Ua) {
2815             CPAN::LWP::UserAgent->config;
2816             eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
2817             if ($@) {
2818                 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
2819                     if $CPAN::DEBUG;
2820             } else {
2821                 my($var);
2822                 $Ua->proxy('ftp',  $var)
2823                     if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
2824                 $Ua->proxy('http', $var)
2825                     if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
2826
2827
2828 # >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
2829 #
2830 #  > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
2831 #  > use ones that require basic autorization.
2832 #
2833 #  > Example of when I use it manually in my own stuff:
2834 #
2835 #  > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
2836 #  > $req->proxy_authorization_basic("username","password");
2837 #  > $res = $ua->request($req);
2838 #
2839
2840                 $Ua->no_proxy($var)
2841                     if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
2842             }
2843         }
2844     }
2845     for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
2846         $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
2847     }
2848
2849     # Try the list of urls for each single object. We keep a record
2850     # where we did get a file from
2851     my(@reordered,$last);
2852     $CPAN::Config->{urllist} ||= [];
2853     unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
2854         $CPAN::Frontend->mywarn("Malformed urllist; ignoring.  Configuration file corrupt?\n");
2855         $CPAN::Config->{urllist} = [];
2856     }
2857     $last = $#{$CPAN::Config->{urllist}};
2858     if ($force & 2) { # local cpans probably out of date, don't reorder
2859         @reordered = (0..$last);
2860     } else {
2861         @reordered =
2862             sort {
2863                 (substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
2864                     <=>
2865                 (substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
2866                     or
2867                 defined($ThesiteURL)
2868                     and
2869                 ($CPAN::Config->{urllist}[$b] eq $ThesiteURL)
2870                     <=>
2871                 ($CPAN::Config->{urllist}[$a] eq $ThesiteURL)
2872             } 0..$last;
2873     }
2874     my(@levels);
2875     $Themethod ||= "";
2876     $self->debug("Themethod[$Themethod]") if $CPAN::DEBUG;
2877     if ($Themethod) {
2878         @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
2879     } else {
2880         @levels = qw/easy hard hardest/;
2881     }
2882     @levels = qw/easy/ if $^O eq 'MacOS';
2883     my($levelno);
2884     local $ENV{FTP_PASSIVE} =
2885         exists $CPAN::Config->{ftp_passive} ?
2886         $CPAN::Config->{ftp_passive} : 1;
2887     for $levelno (0..$#levels) {
2888         my $level = $levels[$levelno];
2889         my $method = "host$level";
2890         my @host_seq = $level eq "easy" ?
2891             @reordered : 0..$last;  # reordered has CDROM up front
2892         my @urllist = map { $CPAN::Config->{urllist}[$_] } @host_seq;
2893         for my $u (@urllist) {
2894             if ($u->can("text")) {
2895                 $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
2896             } else {
2897                 $u .= "/" unless substr($u,-1) eq "/";
2898                 $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
2899             }
2900         }
2901         for my $u (@CPAN::Defaultsites) {
2902             push @urllist, $u unless grep { $_ eq $u } @urllist;
2903         }
2904         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
2905         my $ret = $self->$method(\@urllist,$file,$aslocal);
2906         if ($ret) {
2907           $Themethod = $level;
2908           my $now = time;
2909           # utime $now, $now, $aslocal; # too bad, if we do that, we
2910                                       # might alter a local mirror
2911           $self->debug("level[$level]") if $CPAN::DEBUG;
2912           return $ret;
2913         } else {
2914           unlink $aslocal;
2915           last if $CPAN::Signal; # need to cleanup
2916         }
2917     }
2918     unless ($CPAN::Signal) {
2919         my(@mess);
2920         local $" = " ";
2921         if (@{$CPAN::Config->{urllist}}) {
2922             push @mess,
2923                 qq{Please check, if the URLs I found in your configuration file \(}.
2924                     join(", ", @{$CPAN::Config->{urllist}}).
2925                         qq{\) are valid.};
2926         } else {
2927             push @mess, qq{Your urllist is empty!};
2928         }
2929         push @mess, qq{The urllist can be edited.},
2930             qq{E.g. with 'o conf urllist push ftp://myurl/'};
2931         $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
2932         $CPAN::Frontend->mywarn("Could not fetch $file\n");
2933         $CPAN::Frontend->mysleep(2);
2934     }
2935     if ($restore) {
2936         rename "$aslocal.bak", $aslocal;
2937         $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
2938                                  $self->ls($aslocal));
2939         return $aslocal;
2940     }
2941     return;
2942 }
2943
2944 # package CPAN::FTP;
2945 sub hosteasy {
2946     my($self,$host_seq,$file,$aslocal) = @_;
2947     my($ro_url);
2948   HOSTEASY: for $ro_url (@$host_seq) {
2949         my $url .= "$ro_url$file";
2950         $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
2951         if ($url =~ /^file:/) {
2952             my $l;
2953             if ($CPAN::META->has_inst('URI::URL')) {
2954                 my $u =  URI::URL->new($url);
2955                 $l = $u->path;
2956             } else { # works only on Unix, is poorly constructed, but
2957                 # hopefully better than nothing.
2958                 # RFC 1738 says fileurl BNF is
2959                 # fileurl = "file://" [ host | "localhost" ] "/" fpath
2960                 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
2961                 # the code
2962                 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
2963                 $l =~ s|^file:||;                   # assume they
2964                                                     # meant
2965                                                     # file://localhost
2966                 $l =~ s|^/||s
2967                     if ! -f $l && $l =~ m|^/\w:|;   # e.g. /P:
2968             }
2969             $self->debug("local file[$l]") if $CPAN::DEBUG;
2970             if ( -f $l && -r _) {
2971                 $ThesiteURL = $ro_url;
2972                 return $l;
2973             }
2974             if ($l =~ /(.+)\.gz$/) {
2975                 my $ungz = $1;
2976                 if ( -f $ungz && -r _) {
2977                     $ThesiteURL = $ro_url;
2978                     return $ungz;
2979                 }
2980             }
2981             # Maybe mirror has compressed it?
2982             if (-f "$l.gz") {
2983                 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
2984                 CPAN::Tarzip->new("$l.gz")->gunzip($aslocal);
2985                 if ( -f $aslocal) {
2986                     $ThesiteURL = $ro_url;
2987                     return $aslocal;
2988                 }
2989             }
2990         }
2991         if ($CPAN::META->has_usable('LWP')) {
2992             $CPAN::Frontend->myprint("Fetching with LWP:
2993   $url
2994 ");
2995             unless ($Ua) {
2996                 CPAN::LWP::UserAgent->config;
2997                 eval { $Ua = CPAN::LWP::UserAgent->new; };
2998                 if ($@) {
2999                     $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
3000                 }
3001             }
3002             my $res = $Ua->mirror($url, $aslocal);
3003             if ($res->is_success) {
3004                 $ThesiteURL = $ro_url;
3005                 my $now = time;
3006                 utime $now, $now, $aslocal; # download time is more
3007                                             # important than upload
3008                                             # time
3009                 return $aslocal;
3010             } elsif ($url !~ /\.gz(?!\n)\Z/) {
3011                 my $gzurl = "$url.gz";
3012                 $CPAN::Frontend->myprint("Fetching with LWP:
3013   $gzurl
3014 ");
3015                 $res = $Ua->mirror($gzurl, "$aslocal.gz");
3016                 if ($res->is_success &&
3017                     CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)
3018                    ) {
3019                     $ThesiteURL = $ro_url;
3020                     return $aslocal;
3021                 }
3022             } else {
3023                 $CPAN::Frontend->myprint(sprintf(
3024                                                  "LWP failed with code[%s] message[%s]\n",
3025                                                  $res->code,
3026                                                  $res->message,
3027                                                 ));
3028                 # Alan Burlison informed me that in firewall environments
3029                 # Net::FTP can still succeed where LWP fails. So we do not
3030                 # skip Net::FTP anymore when LWP is available.
3031             }
3032         } elsif (
3033                  $ro_url->can("text")
3034                  and
3035                  $ro_url->{FROM} eq "USER"
3036                 ){
3037             my $ret = $self->hosthard([$ro_url],$file,$aslocal);
3038             return $ret if $ret;
3039         } else {
3040             $CPAN::Frontend->mywarn("  LWP not available\n");
3041         }
3042         return if $CPAN::Signal;
3043         if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3044             # that's the nice and easy way thanks to Graham
3045             my($host,$dir,$getfile) = ($1,$2,$3);
3046             if ($CPAN::META->has_usable('Net::FTP')) {
3047                 $dir =~ s|/+|/|g;
3048                 $CPAN::Frontend->myprint("Fetching with Net::FTP:
3049   $url
3050 ");
3051                 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
3052                              "aslocal[$aslocal]") if $CPAN::DEBUG;
3053                 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
3054                     $ThesiteURL = $ro_url;
3055                     return $aslocal;
3056                 }
3057                 if ($aslocal !~ /\.gz(?!\n)\Z/) {
3058                     my $gz = "$aslocal.gz";
3059                     $CPAN::Frontend->myprint("Fetching with Net::FTP
3060   $url.gz
3061 ");
3062                     if (CPAN::FTP->ftp_get($host,
3063                                            $dir,
3064                                            "$getfile.gz",
3065                                            $gz) &&
3066                         CPAN::Tarzip->new($gz)->gunzip($aslocal)
3067                        ){
3068                         $ThesiteURL = $ro_url;
3069                         return $aslocal;
3070                     }
3071                 }
3072                 # next HOSTEASY;
3073             }
3074         }
3075         return if $CPAN::Signal;
3076     }
3077 }
3078
3079 # package CPAN::FTP;
3080 sub hosthard {
3081   my($self,$host_seq,$file,$aslocal) = @_;
3082
3083   # Came back if Net::FTP couldn't establish connection (or
3084   # failed otherwise) Maybe they are behind a firewall, but they
3085   # gave us a socksified (or other) ftp program...
3086
3087   my($ro_url);
3088   my($devnull) = $CPAN::Config->{devnull} || "";
3089   # < /dev/null ";
3090   my($aslocal_dir) = File::Basename::dirname($aslocal);
3091   File::Path::mkpath($aslocal_dir);
3092   HOSTHARD: for $ro_url (@$host_seq) {
3093         my $url = "$ro_url$file";
3094         my($proto,$host,$dir,$getfile);
3095
3096         # Courtesy Mark Conty mark_conty@cargill.com change from
3097         # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3098         # to
3099         if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
3100           # proto not yet used
3101           ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
3102         } else {
3103           next HOSTHARD; # who said, we could ftp anything except ftp?
3104         }
3105         next HOSTHARD if $proto eq "file"; # file URLs would have had
3106                                            # success above. Likely a bogus URL
3107
3108         $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
3109
3110         # Try the most capable first and leave ncftp* for last as it only
3111         # does FTP.
3112       DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
3113           my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
3114           next unless defined $funkyftp;
3115           next if $funkyftp =~ /^\s*$/;
3116
3117           my($asl_ungz, $asl_gz);
3118           ($asl_ungz = $aslocal) =~ s/\.gz//;
3119           $asl_gz = "$asl_ungz.gz";
3120
3121           my($src_switch) = "";
3122           my($chdir) = "";
3123           my($stdout_redir) = " > $asl_ungz";
3124           if ($f eq "lynx"){
3125             $src_switch = " -source";
3126           } elsif ($f eq "ncftp"){
3127             $src_switch = " -c";
3128           } elsif ($f eq "wget"){
3129             $src_switch = " -O $asl_ungz";
3130             $stdout_redir = "";
3131           } elsif ($f eq 'curl'){
3132             $src_switch = ' -L -f -s -S --netrc-optional';
3133           }
3134
3135           if ($f eq "ncftpget"){
3136             $chdir = "cd $aslocal_dir && ";
3137             $stdout_redir = "";
3138           }
3139           $CPAN::Frontend->myprint(
3140                                    qq[
3141 Trying with "$funkyftp$src_switch" to get
3142     $url
3143 ]);
3144           my($system) =
3145               "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
3146           $self->debug("system[$system]") if $CPAN::DEBUG;
3147           my($wstatus) = system($system);
3148           if ($f eq "lynx") {
3149               # lynx returns 0 when it fails somewhere
3150               if (-s $asl_ungz) {
3151                   my $content = do { local *FH; open FH, $asl_ungz or die; local $/; <FH> };
3152                   if ($content =~ /^<.*<title>[45]/si) {
3153                       $CPAN::Frontend->mywarn(qq{
3154 No success, the file that lynx has has downloaded looks like an error message:
3155 $content
3156 });
3157                       $CPAN::Frontend->mysleep(1);
3158                       next DLPRG;
3159                   }
3160               } else {
3161                   $CPAN::Frontend->myprint(qq{
3162 No success, the file that lynx has has downloaded is an empty file.
3163 });
3164                   next DLPRG;
3165               }
3166           }
3167           if ($wstatus == 0) {
3168             if (-s $aslocal) {
3169               # Looks good
3170             } elsif ($asl_ungz ne $aslocal) {
3171               # test gzip integrity
3172               if (CPAN::Tarzip->new($asl_ungz)->gtest) {
3173                   # e.g. foo.tar is gzipped --> foo.tar.gz
3174                   rename $asl_ungz, $aslocal;
3175               } else {
3176                   CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz);
3177               }
3178             }
3179             $ThesiteURL = $ro_url;
3180             return $aslocal;
3181           } elsif ($url !~ /\.gz(?!\n)\Z/) {
3182             unlink $asl_ungz if
3183                 -f $asl_ungz && -s _ == 0;
3184             my $gz = "$aslocal.gz";
3185             my $gzurl = "$url.gz";
3186             $CPAN::Frontend->myprint(
3187                                      qq[
3188 Trying with "$funkyftp$src_switch" to get
3189   $url.gz
3190 ]);
3191             my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
3192             $self->debug("system[$system]") if $CPAN::DEBUG;
3193             my($wstatus);
3194             if (($wstatus = system($system)) == 0
3195                 &&
3196                 -s $asl_gz
3197                ) {
3198               # test gzip integrity
3199               my $ct = CPAN::Tarzip->new($asl_gz);
3200               if ($ct->gtest) {
3201                   $ct->gunzip($aslocal);
3202               } else {
3203                   # somebody uncompressed file for us?
3204                   rename $asl_ungz, $aslocal;
3205               }
3206               $ThesiteURL = $ro_url;
3207               return $aslocal;
3208             } else {
3209               unlink $asl_gz if -f $asl_gz;
3210             }
3211           } else {
3212             my $estatus = $wstatus >> 8;
3213             my $size = -f $aslocal ?
3214                 ", left\n$aslocal with size ".-s _ :
3215                     "\nWarning: expected file [$aslocal] doesn't exist";
3216             $CPAN::Frontend->myprint(qq{
3217 System call "$system"
3218 returned status $estatus (wstat $wstatus)$size
3219 });
3220           }
3221           return if $CPAN::Signal;
3222         } # transfer programs
3223     } # host
3224 }
3225
3226 # package CPAN::FTP;
3227 sub hosthardest {
3228     my($self,$host_seq,$file,$aslocal) = @_;
3229
3230     my($ro_url);
3231     my($aslocal_dir) = File::Basename::dirname($aslocal);
3232     File::Path::mkpath($aslocal_dir);
3233     my $ftpbin = $CPAN::Config->{ftp};
3234     unless (length $ftpbin && MM->maybe_command($ftpbin)) {
3235         $CPAN::Frontend->myprint("No external ftp command available\n\n");
3236         return;
3237     }
3238     $CPAN::Frontend->mywarn(qq{
3239 As a last ressort we now switch to the external ftp command '$ftpbin'
3240 to get '$aslocal'.
3241
3242 Doing so often leads to problems that are hard to diagnose.
3243
3244 If you're victim of such problems, please consider unsetting the ftp
3245 config variable with
3246
3247     o conf ftp ""
3248     o conf commit
3249
3250 });
3251     $CPAN::Frontend->mysleep(2);
3252   HOSTHARDEST: for $ro_url (@$host_seq) {
3253         my $url = "$ro_url$file";
3254         $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
3255         unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3256             next;
3257         }
3258         my($host,$dir,$getfile) = ($1,$2,$3);
3259         my $timestamp = 0;
3260         my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
3261            $ctime,$blksize,$blocks) = stat($aslocal);
3262         $timestamp = $mtime ||= 0;
3263         my($netrc) = CPAN::FTP::netrc->new;
3264         my($netrcfile) = $netrc->netrc;
3265         my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
3266         my $targetfile = File::Basename::basename($aslocal);
3267         my(@dialog);
3268         push(
3269              @dialog,
3270              "lcd $aslocal_dir",
3271              "cd /",
3272              map("cd $_", split /\//, $dir), # RFC 1738
3273              "bin",
3274              "get $getfile $targetfile",
3275              "quit"
3276             );
3277         if (! $netrcfile) {
3278             CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
3279         } elsif ($netrc->hasdefault || $netrc->contains($host)) {
3280             CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
3281                                 $netrc->hasdefault,
3282                                 $netrc->contains($host))) if $CPAN::DEBUG;
3283             if ($netrc->protected) {
3284                 my $dialog = join "", map { "    $_\n" } @dialog;
3285                 my $netrc_explain;
3286                 if ($netrc->contains($host)) {
3287                     $netrc_explain = "Relying that your .netrc entry for '$host' ".
3288                         "manages the login";
3289                 } else {
3290                     $netrc_explain = "Relying that your default .netrc entry ".
3291                         "manages the login";
3292                 }
3293                 $CPAN::Frontend->myprint(qq{
3294   Trying with external ftp to get
3295     $url
3296   $netrc_explain
3297   Going to send the dialog
3298 $dialog
3299 }
3300                      );
3301                 $self->talk_ftp("$ftpbin$verbose $host",
3302                                 @dialog);
3303                 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
3304                  $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
3305                 $mtime ||= 0;
3306                 if ($mtime > $timestamp) {
3307                     $CPAN::Frontend->myprint("GOT $aslocal\n");
3308                     $ThesiteURL = $ro_url;
3309                     return $aslocal;
3310                 } else {
3311                     $CPAN::Frontend->myprint("Hmm... Still failed!\n");
3312                 }
3313                 return if $CPAN::Signal;
3314             } else {
3315                 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
3316                                         qq{correctly protected.\n});
3317             }
3318         } else {
3319             $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
3320   nor does it have a default entry\n");
3321         }
3322
3323         # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
3324         # then and login manually to host, using e-mail as
3325         # password.
3326         $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
3327         unshift(
3328                 @dialog,
3329                 "open $host",
3330                 "user anonymous $Config::Config{'cf_email'}"
3331                );
3332         my $dialog = join "", map { "    $_\n" } @dialog;
3333         $CPAN::Frontend->myprint(qq{
3334   Trying with external ftp to get
3335     $url
3336   Going to send the dialog
3337 $dialog
3338 }
3339                      );
3340         $self->talk_ftp("$ftpbin$verbose -n", @dialog);
3341         ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
3342          $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
3343         $mtime ||= 0;
3344         if ($mtime > $timestamp) {
3345             $CPAN::Frontend->myprint("GOT $aslocal\n");
3346             $ThesiteURL = $ro_url;
3347             return $aslocal;
3348         } else {
3349             $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
3350         }
3351         return if $CPAN::Signal;
3352         $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
3353         $CPAN::Frontend->mysleep(2);
3354     } # host
3355 }
3356
3357 # package CPAN::FTP;
3358 sub talk_ftp {
3359     my($self,$command,@dialog) = @_;
3360     my $fh = FileHandle->new;
3361     $fh->open("|$command") or die "Couldn't open ftp: $!";
3362     foreach (@dialog) { $fh->print("$_\n") }
3363     $fh->close;         # Wait for process to complete
3364     my $wstatus = $?;
3365     my $estatus = $wstatus >> 8;
3366     $CPAN::Frontend->myprint(qq{
3367 Subprocess "|$command"
3368   returned status $estatus (wstat $wstatus)
3369 }) if $wstatus;
3370 }
3371
3372 # find2perl needs modularization, too, all the following is stolen
3373 # from there
3374 # CPAN::FTP::ls
3375 sub ls {
3376     my($self,$name) = @_;
3377     my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
3378      $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
3379
3380     my($perms,%user,%group);
3381     my $pname = $name;
3382
3383     if ($blocks) {
3384         $blocks = int(($blocks + 1) / 2);
3385     }
3386     else {
3387         $blocks = int(($sizemm + 1023) / 1024);
3388     }
3389
3390     if    (-f _) { $perms = '-'; }
3391     elsif (-d _) { $perms = 'd'; }
3392     elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
3393     elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
3394     elsif (-p _) { $perms = 'p'; }
3395     elsif (-S _) { $perms = 's'; }
3396     else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
3397
3398     my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
3399     my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
3400     my $tmpmode = $mode;
3401     my $tmp = $rwx[$tmpmode & 7];
3402     $tmpmode >>= 3;
3403     $tmp = $rwx[$tmpmode & 7] . $tmp;
3404     $tmpmode >>= 3;
3405     $tmp = $rwx[$tmpmode & 7] . $tmp;
3406     substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
3407     substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
3408     substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
3409     $perms .= $tmp;
3410
3411     my $user = $user{$uid} || $uid;   # too lazy to implement lookup
3412     my $group = $group{$gid} || $gid;
3413
3414     my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
3415     my($timeyear);
3416     my($moname) = $moname[$mon];
3417     if (-M _ > 365.25 / 2) {
3418         $timeyear = $year + 1900;
3419     }
3420     else {
3421         $timeyear = sprintf("%02d:%02d", $hour, $min);
3422     }
3423
3424     sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
3425             $ino,
3426                  $blocks,
3427                       $perms,
3428                             $nlink,
3429                                 $user,
3430                                      $group,
3431                                           $sizemm,
3432                                               $moname,
3433                                                  $mday,
3434                                                      $timeyear,
3435                                                          $pname;
3436 }
3437
3438 package CPAN::FTP::netrc;
3439 use strict;
3440
3441 # package CPAN::FTP::netrc;
3442 sub new {
3443     my($class) = @_;
3444     my $home = CPAN::HandleConfig::home;
3445     my $file = File::Spec->catfile($home,".netrc");
3446
3447     my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
3448        $atime,$mtime,$ctime,$blksize,$blocks)
3449         = stat($file);
3450     $mode ||= 0;
3451     my $protected = 0;
3452
3453     my($fh,@machines,$hasdefault);
3454     $hasdefault = 0;
3455     $fh = FileHandle->new or die "Could not create a filehandle";
3456
3457     if($fh->open($file)){
3458         $protected = ($mode & 077) == 0;
3459         local($/) = "";
3460       NETRC: while (<$fh>) {
3461             my(@tokens) = split " ", $_;
3462           TOKEN: while (@tokens) {
3463                 my($t) = shift @tokens;
3464                 if ($t eq "default"){
3465                     $hasdefault++;
3466                     last NETRC;
3467                 }
3468                 last TOKEN if $t eq "macdef";
3469                 if ($t eq "machine") {
3470                     push @machines, shift @tokens;
3471                 }
3472             }
3473         }
3474     } else {
3475         $file = $hasdefault = $protected = "";
3476     }
3477
3478     bless {
3479            'mach' => [@machines],
3480            'netrc' => $file,
3481            'hasdefault' => $hasdefault,
3482            'protected' => $protected,
3483           }, $class;
3484 }
3485
3486 # CPAN::FTP::netrc::hasdefault;
3487 sub hasdefault { shift->{'hasdefault'} }
3488 sub netrc      { shift->{'netrc'}      }
3489 sub protected  { shift->{'protected'}  }
3490 sub contains {
3491     my($self,$mach) = @_;
3492     for ( @{$self->{'mach'}} ) {
3493         return 1 if $_ eq $mach;
3494     }
3495     return 0;
3496 }
3497
3498 package CPAN::Complete;
3499 use strict;
3500
3501 sub gnu_cpl {
3502     my($text, $line, $start, $end) = @_;
3503     my(@perlret) = cpl($text, $line, $start);
3504     # find longest common match. Can anybody show me how to peruse
3505     # T::R::Gnu to have this done automatically? Seems expensive.
3506     return () unless @perlret;
3507     my($newtext) = $text;
3508     for (my $i = length($text)+1;;$i++) {
3509         last unless length($perlret[0]) && length($perlret[0]) >= $i;
3510         my $try = substr($perlret[0],0,$i);
3511         my @tries = grep {substr($_,0,$i) eq $try} @perlret;
3512         # warn "try[$try]tries[@tries]";
3513         if (@tries == @perlret) {
3514             $newtext = $try;
3515         } else {
3516             last;
3517         }
3518     }
3519     ($newtext,@perlret);
3520 }
3521
3522 #-> sub CPAN::Complete::cpl ;
3523 sub cpl {
3524     my($word,$line,$pos) = @_;
3525     $word ||= "";
3526     $line ||= "";
3527     $pos ||= 0;
3528     CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
3529     $line =~ s/^\s*//;
3530     if ($line =~ s/^(force\s*)//) {
3531         $pos -= length($1);
3532     }
3533     my @return;
3534     if ($pos == 0) {
3535         @return = grep /^$word/, @CPAN::Complete::COMMANDS;
3536     } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
3537         @return = ();
3538     } elsif ($line =~ /^(a|ls)\s/) {
3539         @return = cplx('CPAN::Author',uc($word));
3540     } elsif ($line =~ /^b\s/) {
3541         CPAN::Shell->local_bundles;
3542         @return = cplx('CPAN::Bundle',$word);
3543     } elsif ($line =~ /^d\s/) {
3544         @return = cplx('CPAN::Distribution',$word);
3545     } elsif ($line =~ m/^(
3546                           [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
3547                          )\s/x ) {
3548         if ($word =~ /^Bundle::/) {
3549             CPAN::Shell->local_bundles;
3550         }
3551         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
3552     } elsif ($line =~ /^i\s/) {
3553         @return = cpl_any($word);
3554     } elsif ($line =~ /^reload\s/) {
3555         @return = cpl_reload($word,$line,$pos);
3556     } elsif ($line =~ /^o\s/) {
3557         @return = cpl_option($word,$line,$pos);
3558     } elsif ($line =~ m/^\S+\s/ ) {
3559         # fallback for future commands and what we have forgotten above
3560         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
3561     } else {
3562         @return = ();
3563     }
3564     return @return;
3565 }
3566
3567 #-> sub CPAN::Complete::cplx ;
3568 sub cplx {
3569     my($class, $word) = @_;
3570     # I believed for many years that this was sorted, today I
3571     # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
3572     # make it sorted again. Maybe sort was dropped when GNU-readline
3573     # support came in? The RCS file is difficult to read on that:-(
3574     sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
3575 }
3576
3577 #-> sub CPAN::Complete::cpl_any ;
3578 sub cpl_any {
3579     my($word) = shift;
3580     return (
3581             cplx('CPAN::Author',$word),
3582             cplx('CPAN::Bundle',$word),
3583             cplx('CPAN::Distribution',$word),
3584             cplx('CPAN::Module',$word),
3585            );
3586 }
3587
3588 #-> sub CPAN::Complete::cpl_reload ;
3589 sub cpl_reload {
3590     my($word,$line,$pos) = @_;
3591     $word ||= "";
3592     my(@words) = split " ", $line;
3593     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
3594     my(@ok) = qw(cpan index);
3595     return @ok if @words == 1;
3596     return grep /^\Q$word\E/, @ok if @words == 2 && $word;
3597 }
3598
3599 #-> sub CPAN::Complete::cpl_option ;
3600 sub cpl_option {
3601     my($word,$line,$pos) = @_;
3602     $word ||= "";
3603     my(@words) = split " ", $line;
3604     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
3605     my(@ok) = qw(conf debug);
3606     return @ok if @words == 1;
3607     return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
3608     if (0) {
3609     } elsif ($words[1] eq 'index') {
3610         return ();
3611     } elsif ($words[1] eq 'conf') {
3612         return CPAN::HandleConfig::cpl(@_);
3613     } elsif ($words[1] eq 'debug') {
3614         return sort grep /^\Q$word\E/i,
3615             sort keys %CPAN::DEBUG, 'all';
3616     }
3617 }
3618
3619 package CPAN::Index;
3620 use strict;
3621
3622 #-> sub CPAN::Index::force_reload ;
3623 sub force_reload {
3624     my($class) = @_;
3625     $CPAN::Index::LAST_TIME = 0;
3626     $class->reload(1);
3627 }
3628
3629 #-> sub CPAN::Index::reload ;
3630 sub reload {
3631     my($cl,$force) = @_;
3632     my $time = time;
3633
3634     # XXX check if a newer one is available. (We currently read it
3635     # from time to time)
3636     for ($CPAN::Config->{index_expire}) {
3637         $_ = 0.001 unless $_ && $_ > 0.001;
3638     }
3639     unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
3640         # debug here when CPAN doesn't seem to read the Metadata
3641         require Carp;
3642         Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
3643     }
3644     unless ($CPAN::META->{PROTOCOL}) {
3645         $cl->read_metadata_cache;
3646         $CPAN::META->{PROTOCOL} ||= "1.0";
3647     }
3648     if ( $CPAN::META->{PROTOCOL} < PROTOCOL  ) {
3649         # warn "Setting last_time to 0";
3650         $LAST_TIME = 0; # No warning necessary
3651     }
3652     return if $LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
3653         and ! $force;
3654     if (0) {
3655         # IFF we are developing, it helps to wipe out the memory
3656         # between reloads, otherwise it is not what a user expects.
3657         undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
3658         $CPAN::META = CPAN->new;
3659     }
3660     {
3661         my($debug,$t2);
3662         local $LAST_TIME = $time;
3663         local $CPAN::META->{PROTOCOL} = PROTOCOL;
3664
3665         my $needshort = $^O eq "dos";
3666
3667         $cl->rd_authindex($cl
3668                           ->reload_x(
3669                                      "authors/01mailrc.txt.gz",
3670                                      $needshort ?
3671                                      File::Spec->catfile('authors', '01mailrc.gz') :
3672                                      File::Spec->catfile('authors', '01mailrc.txt.gz'),
3673                                      $force));
3674         $t2 = time;
3675         $debug = "timing reading 01[".($t2 - $time)."]";
3676         $time = $t2;
3677         return if $CPAN::Signal; # this is sometimes lengthy
3678         $cl->rd_modpacks($cl
3679                          ->reload_x(
3680                                     "modules/02packages.details.txt.gz",
3681                                     $needshort ?
3682                                     File::Spec->catfile('modules', '02packag.gz') :
3683                                     File::Spec->catfile('modules', '02packages.details.txt.gz'),
3684                                     $force));
3685         $t2 = time;
3686         $debug .= "02[".($t2 - $time)."]";
3687         $time = $t2;
3688         return if $CPAN::Signal; # this is sometimes lengthy
3689         $cl->rd_modlist($cl
3690                         ->reload_x(
3691                                    "modules/03modlist.data.gz",
3692                                    $needshort ?
3693                                    File::Spec->catfile('modules', '03mlist.gz') :
3694                                    File::Spec->catfile('modules', '03modlist.data.gz'),
3695                                    $force));
3696         $cl->write_metadata_cache;
3697         $t2 = time;
3698         $debug .= "03[".($t2 - $time)."]";
3699         $time = $t2;
3700         CPAN->debug($debug) if $CPAN::DEBUG;
3701     }
3702     $LAST_TIME = $time;
3703     $CPAN::META->{PROTOCOL} = PROTOCOL;
3704 }
3705
3706 #-> sub CPAN::Index::reload_x ;
3707 sub reload_x {
3708     my($cl,$wanted,$localname,$force) = @_;
3709     $force |= 2; # means we're dealing with an index here
3710     CPAN::HandleConfig->load; # we should guarantee loading wherever we rely
3711                         # on Config XXX
3712     $localname ||= $wanted;
3713     my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
3714                                          $localname);
3715     if (
3716         -f $abs_wanted &&
3717         -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
3718         !($force & 1)
3719        ) {
3720         my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
3721         $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
3722                    qq{day$s. I\'ll use that.});
3723         return $abs_wanted;
3724     } else {
3725         $force |= 1; # means we're quite serious about it.
3726     }
3727     return CPAN::FTP->localize($wanted,$abs_wanted,$force);
3728 }
3729
3730 #-> sub CPAN::Index::rd_authindex ;
3731 sub rd_authindex {
3732     my($cl, $index_target) = @_;
3733     my @lines;
3734     return unless defined $index_target;
3735     $CPAN::Frontend->myprint("Going to read $index_target\n");
3736     local(*FH);
3737     tie *FH, 'CPAN::Tarzip', $index_target;
3738     local($/) = "\n";
3739     local($_);
3740     push @lines, split /\012/ while <FH>;
3741     foreach (@lines) {
3742         my($userid,$fullname,$email) =
3743             m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
3744         next unless $userid && $fullname && $email;
3745
3746         # instantiate an author object
3747         my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
3748         $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
3749         return if $CPAN::Signal;
3750     }
3751 }
3752
3753 sub userid {
3754   my($self,$dist) = @_;
3755   $dist = $self->{'id'} unless defined $dist;
3756   my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
3757   $ret;
3758 }
3759
3760 #-> sub CPAN::Index::rd_modpacks ;
3761 sub rd_modpacks {
3762     my($self, $index_target) = @_;
3763     my @lines;
3764     return unless defined $index_target;
3765     $CPAN::Frontend->myprint("Going to read $index_target\n");
3766     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3767     local($/) = "\n";
3768     local $_;
3769     while ($_ = $fh->READLINE) {
3770         s/\012/\n/g;
3771         my @ls = map {"$_\n"} split /\n/, $_;
3772         unshift @ls, "\n" x length($1) if /^(\n+)/;
3773         push @lines, @ls;
3774     }
3775     # read header
3776     my($line_count,$last_updated);
3777     while (@lines) {
3778         my $shift = shift(@lines);
3779         last if $shift =~ /^\s*$/;
3780         $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
3781         $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
3782     }
3783     if (not defined $line_count) {
3784
3785         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
3786 Please check the validity of the index file by comparing it to more
3787 than one CPAN mirror. I'll continue but problems seem likely to
3788 happen.\a
3789 });
3790
3791         $CPAN::Frontend->mysleep(5);
3792     } elsif ($line_count != scalar @lines) {
3793
3794         $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
3795 contains a Line-Count header of %d but I see %d lines there. Please
3796 check the validity of the index file by comparing it to more than one
3797 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
3798 $index_target, $line_count, scalar(@lines));
3799
3800     }
3801     if (not defined $last_updated) {
3802
3803         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
3804 Please check the validity of the index file by comparing it to more
3805 than one CPAN mirror. I'll continue but problems seem likely to
3806 happen.\a
3807 });
3808
3809         $CPAN::Frontend->mysleep(5);
3810     } else {
3811
3812         $CPAN::Frontend
3813             ->myprint(sprintf qq{  Database was generated on %s\n},
3814                       $last_updated);
3815         $DATE_OF_02 = $last_updated;
3816
3817         my $age = time;
3818         if ($CPAN::META->has_inst('HTTP::Date')) {
3819             require HTTP::Date;
3820             $age -= HTTP::Date::str2time($last_updated);
3821         } else {
3822             $CPAN::Frontend->mywarn("  HTTP::Date not available\n");
3823             require Time::Local;
3824             my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
3825             $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
3826             $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
3827         }
3828         $age /= 3600*24;
3829         if ($age > 30) {
3830
3831             $CPAN::Frontend
3832                 ->mywarn(sprintf
3833                          qq{Warning: This index file is %d days old.
3834   Please check the host you chose as your CPAN mirror for staleness.
3835   I'll continue but problems seem likely to happen.\a\n},
3836                          $age);
3837
3838         } elsif ($age < -1) {
3839
3840             $CPAN::Frontend
3841                 ->mywarn(sprintf
3842                          qq{Warning: Your system date is %d days behind this index file!
3843   System time:          %s
3844   Timestamp index file: %s
3845   Please fix your system time, problems with the make command expected.\n},
3846                          -$age,
3847                          scalar gmtime,
3848                          $DATE_OF_02,
3849                         );
3850
3851         }
3852     }
3853
3854
3855     # A necessity since we have metadata_cache: delete what isn't
3856     # there anymore
3857     my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
3858     CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
3859     my(%exists);
3860     foreach (@lines) {
3861         chomp;
3862         # before 1.56 we split into 3 and discarded the rest. From
3863         # 1.57 we assign remaining text to $comment thus allowing to
3864         # influence isa_perl
3865         my($mod,$version,$dist,$comment) = split " ", $_, 4;
3866         my($bundle,$id,$userid);
3867
3868         if ($mod eq 'CPAN' &&
3869             ! (
3870                CPAN::Queue->exists('Bundle::CPAN') ||
3871                CPAN::Queue->exists('CPAN')
3872               )
3873            ) {
3874             local($^W)= 0;
3875             if ($version > $CPAN::VERSION){
3876                 $CPAN::Frontend->mywarn(qq{
3877   New CPAN.pm version (v$version) available.
3878   [Currently running version is v$CPAN::VERSION]
3879   You might want to try
3880     install CPAN
3881     reload cpan
3882   to both upgrade CPAN.pm and run the new version without leaving
3883   the current session.
3884
3885 }); #});
3886                 $CPAN::Frontend->mysleep(2);
3887                 $CPAN::Frontend->myprint(qq{\n});
3888             }
3889             last if $CPAN::Signal;
3890         } elsif ($mod =~ /^Bundle::(.*)/) {
3891             $bundle = $1;
3892         }
3893
3894         if ($bundle){
3895             $id =  $CPAN::META->instance('CPAN::Bundle',$mod);
3896             # Let's make it a module too, because bundles have so much
3897             # in common with modules.
3898
3899             # Changed in 1.57_63: seems like memory bloat now without
3900             # any value, so commented out
3901
3902             # $CPAN::META->instance('CPAN::Module',$mod);
3903
3904         } else {
3905
3906             # instantiate a module object
3907             $id = $CPAN::META->instance('CPAN::Module',$mod);
3908
3909         }
3910
3911         # Although CPAN prohibits same name with different version the
3912         # indexer may have changed the version for the same distro
3913         # since the last time ("Force Reindexing" feature)
3914         if ($id->cpan_file ne $dist
3915             ||
3916             $id->cpan_version ne $version
3917            ){
3918             $userid = $id->userid || $self->userid($dist);
3919             $id->set(
3920                      'CPAN_USERID' => $userid,
3921                      'CPAN_VERSION' => $version,
3922                      'CPAN_FILE' => $dist,
3923                     );
3924         }
3925
3926         # instantiate a distribution object
3927         if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
3928           # we do not need CONTAINSMODS unless we do something with
3929           # this dist, so we better produce it on demand.
3930
3931           ## my $obj = $CPAN::META->instance(
3932           ##                              'CPAN::Distribution' => $dist
3933           ##                             );
3934           ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
3935         } else {
3936           $CPAN::META->instance(
3937                                 'CPAN::Distribution' => $dist
3938                                )->set(
3939                                       'CPAN_USERID' => $userid,
3940                                       'CPAN_COMMENT' => $comment,
3941                                      );
3942         }
3943         if ($secondtime) {
3944             for my $name ($mod,$dist) {
3945                 CPAN->debug("exists name[$name]") if $CPAN::DEBUG;
3946                 $exists{$name} = undef;
3947             }
3948         }
3949         return if $CPAN::Signal;
3950     }
3951     undef $fh;
3952     if ($secondtime) {
3953         for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
3954             for my $o ($CPAN::META->all_objects($class)) {
3955                 next if exists $exists{$o->{ID}};
3956                 $CPAN::META->delete($class,$o->{ID});
3957                 CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
3958                     if $CPAN::DEBUG;
3959             }
3960         }
3961     }
3962 }
3963
3964 #-> sub CPAN::Index::rd_modlist ;
3965 sub rd_modlist {
3966     my($cl,$index_target) = @_;
3967     return unless defined $index_target;
3968     $CPAN::Frontend->myprint("Going to read $index_target\n");
3969     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3970     my @eval;
3971     local($/) = "\n";
3972     local $_;
3973     while ($_ = $fh->READLINE) {
3974         s/\012/\n/g;
3975         my @ls = map {"$_\n"} split /\n/, $_;
3976         unshift @ls, "\n" x length($1) if /^(\n+)/;
3977         push @eval, @ls;
3978     }
3979     while (@eval) {
3980         my $shift = shift(@eval);
3981         if ($shift =~ /^Date:\s+(.*)/){
3982             return if $DATE_OF_03 eq $1;
3983             ($DATE_OF_03) = $1;
3984         }
3985         last if $shift =~ /^\s*$/;
3986     }
3987     undef $fh;
3988     push @eval, q{CPAN::Modulelist->data;};
3989     local($^W) = 0;
3990     my($comp) = Safe->new("CPAN::Safe1");
3991     my($eval) = join("", @eval);
3992     my $ret = $comp->reval($eval);
3993     Carp::confess($@) if $@;
3994     return if $CPAN::Signal;
3995     for (keys %$ret) {
3996         my $obj = $CPAN::META->instance("CPAN::Module",$_);
3997         delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
3998         $obj->set(%{$ret->{$_}});
3999         return if $CPAN::Signal;
4000     }
4001 }
4002
4003 #-> sub CPAN::Index::write_metadata_cache ;
4004 sub write_metadata_cache {
4005     my($self) = @_;
4006     return unless $CPAN::Config->{'cache_metadata'};
4007     return unless $CPAN::META->has_usable("Storable");
4008     my $cache;
4009     foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
4010                       CPAN::Distribution)) {
4011         $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
4012     }
4013     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
4014     $cache->{last_time} = $LAST_TIME;
4015     $cache->{DATE_OF_02} = $DATE_OF_02;
4016     $cache->{PROTOCOL} = PROTOCOL;
4017     $CPAN::Frontend->myprint("Going to write $metadata_file\n");
4018     eval { Storable::nstore($cache, $metadata_file) };
4019     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
4020 }
4021
4022 #-> sub CPAN::Index::read_metadata_cache ;
4023 sub read_metadata_cache {
4024     my($self) = @_;
4025     return unless $CPAN::Config->{'cache_metadata'};
4026     return unless $CPAN::META->has_usable("Storable");
4027     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
4028     return unless -r $metadata_file and -f $metadata_file;
4029     $CPAN::Frontend->myprint("Going to read $metadata_file\n");
4030     my $cache;
4031     eval { $cache = Storable::retrieve($metadata_file) };
4032     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
4033     if (!$cache || ref $cache ne 'HASH'){
4034         $LAST_TIME = 0;
4035         return;
4036     }
4037     if (exists $cache->{PROTOCOL}) {
4038         if (PROTOCOL > $cache->{PROTOCOL}) {
4039             $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
4040                                             "with protocol v%s, requiring v%s\n",
4041                                             $cache->{PROTOCOL},
4042                                             PROTOCOL)
4043                                    );
4044             return;
4045         }
4046     } else {
4047         $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
4048                                 "with protocol v1.0\n");
4049         return;
4050     }
4051     my $clcnt = 0;
4052     my $idcnt = 0;
4053     while(my($class,$v) = each %$cache) {
4054         next unless $class =~ /^CPAN::/;
4055         $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
4056         while (my($id,$ro) = each %$v) {
4057             $CPAN::META->{readwrite}{$class}{$id} ||=
4058                 $class->new(ID=>$id, RO=>$ro);
4059             $idcnt++;
4060         }
4061         $clcnt++;
4062     }
4063     unless ($clcnt) { # sanity check
4064         $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
4065         return;
4066     }
4067     if ($idcnt < 1000) {
4068         $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
4069                                  "in $metadata_file\n");
4070         return;
4071     }
4072     $CPAN::META->{PROTOCOL} ||=
4073         $cache->{PROTOCOL}; # reading does not up or downgrade, but it
4074                             # does initialize to some protocol
4075     $LAST_TIME = $cache->{last_time};
4076     $DATE_OF_02 = $cache->{DATE_OF_02};
4077     $CPAN::Frontend->myprint("  Database was generated on $DATE_OF_02\n")
4078         if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
4079     return;
4080 }
4081
4082 package CPAN::InfoObj;
4083 use strict;
4084
4085 sub ro {
4086     my $self = shift;
4087     exists $self->{RO} and return $self->{RO};
4088 }
4089
4090 sub cpan_userid {
4091     my $self = shift;
4092     my $ro = $self->ro or return "N/A"; # N/A for bundles found locally
4093     return $ro->{CPAN_USERID} || "N/A";
4094 }
4095
4096 sub id { shift->{ID}; }
4097
4098 #-> sub CPAN::InfoObj::new ;
4099 sub new {
4100     my $this = bless {}, shift;
4101     %$this = @_;
4102     $this
4103 }
4104
4105 # The set method may only be used by code that reads index data or
4106 # otherwise "objective" data from the outside world. All session
4107 # related material may do anything else with instance variables but
4108 # must not touch the hash under the RO attribute. The reason is that
4109 # the RO hash gets written to Metadata file and is thus persistent.
4110
4111 #-> sub CPAN::InfoObj::safe_chdir ;
4112 sub safe_chdir {
4113   my($self,$todir) = @_;
4114   # we die if we cannot chdir and we are debuggable
4115   Carp::confess("safe_chdir called without todir argument")
4116         unless defined $todir and length $todir;
4117   if (chdir $todir) {
4118     $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
4119         if $CPAN::DEBUG;
4120   } else {
4121     if (-e $todir) {
4122         unless (-x $todir) {
4123             unless (chmod 0755, $todir) {
4124                 my $cwd = CPAN::anycwd();
4125                 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
4126                                         "permission to change the permission; cannot ".
4127                                         "chdir to '$todir'\n");
4128                 $CPAN::Frontend->mysleep(5);
4129                 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
4130                                        qq{to todir[$todir]: $!});
4131             }
4132         }
4133     } else {
4134         $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n");
4135     }
4136     if (chdir $todir) {
4137       $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
4138           if $CPAN::DEBUG;
4139     } else {
4140       my $cwd = CPAN::anycwd();
4141       $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
4142                              qq{to todir[$todir] (a chmod has been issued): $!});
4143     }
4144   }
4145 }
4146
4147 #-> sub CPAN::InfoObj::set ;
4148 sub set {
4149     my($self,%att) = @_;
4150     my $class = ref $self;
4151
4152     # This must be ||=, not ||, because only if we write an empty
4153     # reference, only then the set method will write into the readonly
4154     # area. But for Distributions that spring into existence, maybe
4155     # because of a typo, we do not like it that they are written into
4156     # the readonly area and made permanent (at least for a while) and
4157     # that is why we do not "allow" other places to call ->set.
4158     unless ($self->id) {
4159         CPAN->debug("Bug? Empty ID, rejecting");
4160         return;
4161     }
4162     my $ro = $self->{RO} =
4163         $CPAN::META->{readonly}{$class}{$self->id} ||= {};
4164
4165     while (my($k,$v) = each %att) {
4166         $ro->{$k} = $v;
4167     }
4168 }
4169
4170 #-> sub CPAN::InfoObj::as_glimpse ;
4171 sub as_glimpse {
4172     my($self) = @_;
4173     my(@m);
4174     my $class = ref($self);
4175     $class =~ s/^CPAN:://;
4176     push @m, sprintf "%-15s %s\n", $class, $self->{ID};
4177     join "", @m;
4178 }
4179
4180 #-> sub CPAN::InfoObj::as_string ;
4181 sub as_string {
4182     my($self) = @_;
4183     my(@m);
4184     my $class = ref($self);
4185     $class =~ s/^CPAN:://;
4186     push @m, $class, " id = $self->{ID}\n";
4187     my $ro;
4188     unless ($ro = $self->ro) {
4189         $CPAN::Frontend->mydie("Unknown object $self->{ID}");
4190     }
4191     for (sort keys %$ro) {
4192         # next if m/^(ID|RO)$/;
4193         my $extra = "";
4194         if ($_ eq "CPAN_USERID") {
4195             $extra .= " (";
4196             $extra .= $self->fullname;
4197             my $email; # old perls!
4198             if ($email = $CPAN::META->instance("CPAN::Author",
4199                                                $self->cpan_userid
4200                                               )->email) {
4201                 $extra .= " <$email>";
4202             } else {
4203                 $extra .= " <no email>";
4204             }
4205             $extra .= ")";
4206         } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
4207             push @m, sprintf "    %-12s %s\n", $_, $self->fullname;
4208             next;
4209         }
4210         next unless defined $ro->{$_};
4211         push @m, sprintf "    %-12s %s%s\n", $_, $ro->{$_}, $extra;
4212     }
4213     for (sort keys %$self) {
4214         next if m/^(ID|RO)$/;
4215         if (ref($self->{$_}) eq "ARRAY") {
4216           push @m, sprintf "    %-12s %s\n", $_, "@{$self->{$_}}";
4217         } elsif (ref($self->{$_}) eq "HASH") {
4218           push @m, sprintf(
4219                            "    %-12s %s\n",
4220                            $_,
4221                            join(" ",sort keys %{$self->{$_}}),
4222                           );
4223         } else {
4224           push @m, sprintf "    %-12s %s\n", $_, $self->{$_};
4225         }
4226     }
4227     join "", @m, "\n";
4228 }
4229
4230 #-> sub CPAN::InfoObj::fullname ;
4231 sub fullname {
4232     my($self) = @_;
4233     $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
4234 }
4235
4236 #-> sub CPAN::InfoObj::dump ;
4237 sub dump {
4238   my($self) = @_;
4239   unless ($CPAN::META->has_inst("Data::Dumper")) {
4240       $CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
4241   }
4242   local $Data::Dumper::Sortkeys;
4243   $Data::Dumper::Sortkeys = 1;
4244   $CPAN::Frontend->myprint(Data::Dumper::Dumper($self));
4245 }
4246
4247 package CPAN::Author;
4248 use strict;
4249
4250 #-> sub CPAN::Author::force
4251 sub force {
4252     my $self = shift;
4253     $self->{force}++;
4254 }
4255
4256 #-> sub CPAN::Author::force
4257 sub unforce {
4258     my $self = shift;
4259     delete $self->{force};
4260 }
4261
4262 #-> sub CPAN::Author::id
4263 sub id {
4264     my $self = shift;
4265     my $id = $self->{ID};
4266     $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
4267     $id;
4268 }
4269
4270 #-> sub CPAN::Author::as_glimpse ;
4271 sub as_glimpse {
4272     my($self) = @_;
4273     my(@m);
4274     my $class = ref($self);
4275     $class =~ s/^CPAN:://;
4276     push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
4277                      $class,
4278                      $self->{ID},
4279                      $self->fullname,
4280                      $self->email);
4281     join "", @m;
4282 }
4283
4284 #-> sub CPAN::Author::fullname ;
4285 sub fullname {
4286     shift->ro->{FULLNAME};
4287 }
4288 *name = \&fullname;
4289
4290 #-> sub CPAN::Author::email ;
4291 sub email    { shift->ro->{EMAIL}; }
4292
4293 #-> sub CPAN::Author::ls ;
4294 sub ls {
4295     my $self = shift;
4296     my $glob = shift || "";
4297     my $silent = shift || 0;
4298     my $id = $self->id;
4299
4300     # adapted from CPAN::Distribution::verifyCHECKSUM ;
4301     my(@csf); # chksumfile
4302     @csf = $self->id =~ /(.)(.)(.*)/;
4303     $csf[1] = join "", @csf[0,1];
4304     $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
4305     my(@dl);
4306     @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
4307     unless (grep {$_->[2] eq $csf[1]} @dl) {
4308         $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
4309         return;
4310     }
4311     @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
4312     unless (grep {$_->[2] eq $csf[2]} @dl) {
4313         $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
4314         return;
4315     }
4316     @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
4317     if ($glob) {
4318         if ($CPAN::META->has_inst("Text::Glob")) {
4319             my $rglob = Text::Glob::glob_to_regex($glob);
4320             @dl = grep { $_->[2] =~ /$rglob/ } @dl;
4321         } else {
4322             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
4323         }
4324     }
4325     $CPAN::Frontend->myprint(join "", map {
4326         sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
4327     } sort { $a->[2] cmp $b->[2] } @dl);
4328     @dl;
4329 }
4330
4331 # returns an array of arrays, the latter contain (size,mtime,filename)
4332 #-> sub CPAN::Author::dir_listing ;
4333 sub dir_listing {
4334     my $self = shift;
4335     my $chksumfile = shift;
4336     my $recursive = shift;
4337     my $may_ftp = shift;
4338
4339     my $lc_want =
4340         File::Spec->catfile($CPAN::Config->{keep_source_where},
4341                             "authors", "id", @$chksumfile);
4342
4343     my $fh;
4344
4345     # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
4346     # hazard.  (Without GPG installed they are not that much better,
4347     # though.)
4348     $fh = FileHandle->new;
4349     if (open($fh, $lc_want)) {
4350         my $line = <$fh>; close $fh;
4351         unlink($lc_want) unless $line =~ /PGP/;
4352     }
4353
4354     local($") = "/";
4355     # connect "force" argument with "index_expire".
4356     my $force = $self->{force};
4357     if (my @stat = stat $lc_want) {
4358         $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
4359     }
4360     my $lc_file;
4361     if ($may_ftp) {
4362         $lc_file = CPAN::FTP->localize(
4363                                        "authors/id/@$chksumfile",
4364                                        $lc_want,
4365                                        $force,
4366                                       );
4367         unless ($lc_file) {
4368             $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
4369             $chksumfile->[-1] .= ".gz";
4370             $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
4371                                            "$lc_want.gz",1);
4372             if ($lc_file) {
4373                 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
4374                 CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file);
4375             } else {
4376                 return;
4377             }
4378         }
4379     } else {
4380         $lc_file = $lc_want;
4381         # we *could* second-guess and if the user has a file: URL,
4382         # then we could look there. But on the other hand, if they do
4383         # have a file: URL, wy did they choose to set
4384         # $CPAN::Config->{show_upload_date} to false?
4385     }
4386
4387     # adapted from CPAN::Distribution::CHECKSUM_check_file ;
4388     $fh = FileHandle->new;
4389     my($cksum);
4390     if (open $fh, $lc_file){
4391         local($/);
4392         my $eval = <$fh>;
4393         $eval =~ s/\015?\012/\n/g;
4394         close $fh;
4395         my($comp) = Safe->new();
4396         $cksum = $comp->reval($eval);
4397         if ($@) {
4398             rename $lc_file, "$lc_file.bad";
4399             Carp::confess($@) if $@;
4400         }
4401     } elsif ($may_ftp) {
4402         Carp::carp "Could not open '$lc_file' for reading.";
4403     } else {
4404         # Maybe should warn: "You may want to set show_upload_date to a true value"
4405         return;
4406     }
4407     my(@result,$f);
4408     for $f (sort keys %$cksum) {
4409         if (exists $cksum->{$f}{isdir}) {
4410             if ($recursive) {
4411                 my(@dir) = @$chksumfile;
4412                 pop @dir;
4413                 push @dir, $f, "CHECKSUMS";
4414                 push @result, map {
4415                     [$_->[0], $_->[1], "$f/$_->[2]"]
4416                 } $self->dir_listing(\@dir,1,$may_ftp);
4417             } else {
4418                 push @result, [ 0, "-", $f ];
4419             }
4420         } else {
4421             push @result, [
4422                            ($cksum->{$f}{"size"}||0),
4423                            $cksum->{$f}{"mtime"}||"---",
4424                            $f
4425                           ];
4426         }
4427     }
4428     @result;
4429 }
4430
4431 package CPAN::Distribution;
4432 use strict;
4433
4434 # Accessors
4435 sub cpan_comment {
4436     my $self = shift;
4437     my $ro = $self->ro or return;
4438     $ro->{CPAN_COMMENT}
4439 }
4440
4441 # CPAN::Distribution::undelay
4442 sub undelay {
4443     my $self = shift;
4444     delete $self->{later};
4445 }
4446
4447 # add the A/AN/ stuff
4448 # CPAN::Distribution::normalize
4449 sub normalize {
4450     my($self,$s) = @_;
4451     $s = $self->id unless defined $s;
4452     if (
4453         $s =~ tr|/|| == 1
4454         or
4455         $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
4456        ) {
4457         return $s if $s =~ m:^N/A|^Contact Author: ;
4458         $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
4459             $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
4460         CPAN->debug("s[$s]") if $CPAN::DEBUG;
4461     }
4462     $s;
4463 }
4464
4465 #-> sub CPAN::Distribution::author ;
4466 sub author {
4467     my($self) = @_;
4468     my($authorid) = $self->pretty_id =~ /^([\w\-]+)/;
4469     CPAN::Shell->expand("Author",$authorid);
4470 }
4471
4472 # tries to get the yaml from CPAN instead of the distro itself:
4473 # EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels
4474 sub fast_yaml {
4475     my($self) = @_;
4476     my $meta = $self->pretty_id;
4477     $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/;
4478     my(@ls) = CPAN::Shell->globls($meta);
4479     my $norm = $self->normalize($meta);
4480
4481     my($local_file);
4482     my($local_wanted) =
4483         File::Spec->catfile(
4484                             $CPAN::Config->{keep_source_where},
4485                             "authors",
4486                             "id",
4487                             split(/\//,$norm)
4488                            );
4489     $self->debug("Doing localize") if $CPAN::DEBUG;
4490     unless ($local_file =
4491             CPAN::FTP->localize("authors/id/$norm",
4492                                 $local_wanted)) {
4493         $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n");
4494     }
4495     if ($CPAN::META->has_inst("YAML")) {
4496         my $yaml = YAML::LoadFile($local_file);
4497         return $yaml;
4498     } else {
4499         $CPAN::Frontend->mydie("Yaml not installed, cannot parse '$local_file'\n");
4500     }
4501 }
4502
4503 sub pretty_id {
4504     my $self = shift;
4505     my $id = $self->id;
4506     return $id unless $id =~ m|^./../|;
4507     substr($id,5);
4508 }
4509
4510 # mark as dirty/clean
4511 #-> sub CPAN::Distribution::color_cmd_tmps ;
4512 sub color_cmd_tmps {
4513     my($self) = shift;
4514     my($depth) = shift || 0;
4515     my($color) = shift || 0;
4516     my($ancestors) = shift || [];
4517     # a distribution needs to recurse into its prereq_pms
4518
4519     return if exists $self->{incommandcolor}
4520         && $self->{incommandcolor}==$color;
4521     if ($depth>=100){
4522         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
4523     }
4524     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
4525     my $prereq_pm = $self->prereq_pm;
4526     if (defined $prereq_pm) {
4527       PREREQ: for my $pre (keys %$prereq_pm) {
4528             my $premo;
4529             unless ($premo = CPAN::Shell->expand("Module",$pre)) {
4530                 $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n");
4531                 $CPAN::Frontend->mysleep(2);
4532                 next PREREQ;
4533             }
4534             $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
4535         }
4536     }
4537     if ($color==0) {
4538         delete $self->{sponsored_mods};
4539         delete $self->{badtestcnt};
4540     }
4541     $self->{incommandcolor} = $color;
4542 }
4543
4544 #-> sub CPAN::Distribution::as_string ;
4545 sub as_string {
4546   my $self = shift;
4547   $self->containsmods;
4548   $self->upload_date;
4549   $self->SUPER::as_string(@_);
4550 }
4551
4552 #-> sub CPAN::Distribution::containsmods ;
4553 sub containsmods {
4554   my $self = shift;
4555   return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
4556   my $dist_id = $self->{ID};
4557   for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
4558     my $mod_file = $mod->cpan_file or next;
4559     my $mod_id = $mod->{ID} or next;
4560     # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
4561     # sleep 1;
4562     $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
4563   }
4564   keys %{$self->{CONTAINSMODS}};
4565 }
4566
4567 #-> sub CPAN::Distribution::upload_date ;
4568 sub upload_date {
4569   my $self = shift;
4570   return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
4571   my(@local_wanted) = split(/\//,$self->id);
4572   my $filename = pop @local_wanted;
4573   push @local_wanted, "CHECKSUMS";
4574   my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
4575   return unless $author;
4576   my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
4577   return unless @dl;
4578   my($dirent) = grep { $_->[2] eq $filename } @dl;
4579   # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
4580   return unless $dirent->[1];
4581   return $self->{UPLOAD_DATE} = $dirent->[1];
4582 }
4583
4584 #-> sub CPAN::Distribution::uptodate ;
4585 sub uptodate {
4586     my($self) = @_;
4587     my $c;
4588     foreach $c ($self->containsmods) {
4589         my $obj = CPAN::Shell->expandany($c);
4590         unless ($obj->uptodate){
4591             my $id = $self->pretty_id;
4592             $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG;
4593             return 0;
4594         }
4595     }
4596     return 1;
4597 }
4598
4599 #-> sub CPAN::Distribution::called_for ;
4600 sub called_for {
4601     my($self,$id) = @_;
4602     $self->{CALLED_FOR} = $id if defined $id;
4603     return $self->{CALLED_FOR};
4604 }
4605
4606 #-> sub CPAN::Distribution::get ;
4607 sub get {
4608     my($self) = @_;
4609   EXCUSE: {
4610         my @e;
4611         exists $self->{'build_dir'} and push @e,
4612             "Is already unwrapped into directory $self->{'build_dir'}";
4613         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
4614     }
4615     my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
4616
4617     #
4618     # Get the file on local disk
4619     #
4620
4621     my($local_file);
4622     my($local_wanted) =
4623         File::Spec->catfile(
4624                             $CPAN::Config->{keep_source_where},
4625                             "authors",
4626                             "id",
4627                             split(/\//,$self->id)
4628                            );
4629
4630     $self->debug("Doing localize") if $CPAN::DEBUG;
4631     unless ($local_file =
4632             CPAN::FTP->localize("authors/id/$self->{ID}",
4633                                 $local_wanted)) {
4634         my $note = "";
4635         if ($CPAN::Index::DATE_OF_02) {
4636             $note = "Note: Current database in memory was generated ".
4637                 "on $CPAN::Index::DATE_OF_02\n";
4638         }
4639         $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
4640     }
4641     $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
4642     $self->{localfile} = $local_file;
4643     return if $CPAN::Signal;
4644
4645     #
4646     # Check integrity
4647     #
4648     if ($CPAN::META->has_inst("Digest::SHA")) {
4649         $self->debug("Digest::SHA is installed, verifying");
4650         $self->verifyCHECKSUM;
4651     } else {
4652         $self->debug("Digest::SHA is NOT installed");
4653     }
4654     return if $CPAN::Signal;
4655
4656     #
4657     # Create a clean room and go there
4658     #
4659     $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
4660     my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
4661     $self->safe_chdir($builddir);
4662     $self->debug("Removing tmp") if $CPAN::DEBUG;
4663     File::Path::rmtree("tmp");
4664     unless (mkdir "tmp", 0755) {
4665         $CPAN::Frontend->unrecoverable_error(<<EOF);
4666 Couldn't mkdir '$builddir/tmp': $!
4667
4668 Cannot continue: Please find the reason why I cannot make the
4669 directory
4670 $builddir/tmp
4671 and fix the problem, then retry.
4672
4673 EOF
4674     }
4675     if ($CPAN::Signal){
4676         $self->safe_chdir($sub_wd);
4677         return;
4678     }
4679     $self->safe_chdir("tmp");
4680
4681     #
4682     # Unpack the goods
4683     #
4684     $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
4685     my $ct = CPAN::Tarzip->new($local_file);
4686     if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i){
4687         $self->{was_uncompressed}++ unless $ct->gtest();
4688         $self->untar_me($ct);
4689     } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
4690         $self->unzip_me($ct);
4691     } else {
4692         $self->{was_uncompressed}++ unless $ct->gtest();
4693         $self->debug("calling pm2dir for local_file[$local_file]")
4694           if $CPAN::DEBUG;
4695         $local_file = $self->handle_singlefile($local_file);
4696 #    } else {
4697 #       $self->{archived} = "NO";
4698 #        $self->safe_chdir($sub_wd);
4699 #        return;
4700     }
4701
4702     # we are still in the tmp directory!
4703     # Let's check if the package has its own directory.
4704     my $dh = DirHandle->new(File::Spec->curdir)
4705         or Carp::croak("Couldn't opendir .: $!");
4706     my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
4707     $dh->close;
4708     my ($distdir,$packagedir);
4709     if (@readdir == 1 && -d $readdir[0]) {
4710         $distdir = $readdir[0];
4711         $packagedir = File::Spec->catdir($builddir,$distdir);
4712         $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
4713             if $CPAN::DEBUG;
4714         -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
4715                                                     "$packagedir\n");
4716         File::Path::rmtree($packagedir);
4717         unless (File::Copy::move($distdir,$packagedir)) {
4718             $CPAN::Frontend->unrecoverable_error(<<EOF);
4719 Couldn't move '$distdir' to '$packagedir': $!
4720
4721 Cannot continue: Please find the reason why I cannot move
4722 $builddir/tmp/$distdir
4723 to
4724 $packagedir
4725 and fix the problem, then retry
4726
4727 EOF
4728         }
4729         $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
4730                              $distdir,
4731                              $packagedir,
4732                              -e $packagedir,
4733                              -d $packagedir,
4734                             )) if $CPAN::DEBUG;
4735     } else {
4736         my $userid = $self->cpan_userid;
4737         unless ($userid) {
4738             CPAN->debug("no userid? self[$self]");
4739             $userid = "anon";
4740         }
4741         my $pragmatic_dir = $userid . '000';
4742         $pragmatic_dir =~ s/\W_//g;
4743         $pragmatic_dir++ while -d "../$pragmatic_dir";
4744         $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
4745         $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
4746         File::Path::mkpath($packagedir);
4747         my($f);
4748         for $f (@readdir) { # is already without "." and ".."
4749             my $to = File::Spec->catdir($packagedir,$f);
4750             File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
4751         }
4752     }
4753     if ($CPAN::Signal){
4754         $self->safe_chdir($sub_wd);
4755         return;
4756     }
4757
4758     $self->{'build_dir'} = $packagedir;
4759     $self->safe_chdir($builddir);
4760     File::Path::rmtree("tmp");
4761
4762     $self->safe_chdir($packagedir);
4763     if ($CPAN::Config->{check_sigs}) {
4764         if ($CPAN::META->has_inst("Module::Signature")) {
4765             if (-f "SIGNATURE") {
4766                 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
4767                 my $rv = Module::Signature::verify();
4768                 if ($rv != Module::Signature::SIGNATURE_OK() and
4769                     $rv != Module::Signature::SIGNATURE_MISSING()) {
4770                     $CPAN::Frontend->myprint(
4771                                              qq{\nSignature invalid for }.
4772                                              qq{distribution file. }.
4773                                              qq{Please investigate.\n\n}.
4774                                              $self->as_string,
4775                                              $CPAN::META->instance(
4776                                                                    'CPAN::Author',
4777                                                                    $self->cpan_userid,
4778                                                                   )->as_string
4779                                             );
4780
4781                     my $wrap =
4782                         sprintf(qq{I'd recommend removing %s. Its signature
4783 is invalid. Maybe you have configured your 'urllist' with
4784 a bad URL. Please check this array with 'o conf urllist', and
4785 retry. For more information, try opening a subshell with
4786   look %s
4787 and there run
4788   cpansign -v
4789 },
4790                                 $self->{localfile},
4791                                 $self->pretty_id,
4792                                );
4793                     $self->{signature_verify} = CPAN::Distrostatus->new("NO");
4794                     $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
4795                     $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
4796                 } else {
4797                     $self->{signature_verify} = CPAN::Distrostatus->new("YES");
4798                     $self->debug("Module::Signature has verified") if $CPAN::DEBUG;
4799                 }
4800             } else {
4801                 $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n});
4802             }
4803         } else {
4804             $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
4805         }
4806     }
4807     $self->safe_chdir($builddir);
4808     return if $CPAN::Signal;
4809
4810
4811     my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
4812     my($mpl_exists) = -f $mpl;
4813     unless ($mpl_exists) {
4814         # NFS has been reported to have racing problems after the
4815         # renaming of a directory in some environments.
4816         # This trick helps.
4817         $CPAN::Frontend->mysleep(1);
4818         my $mpldh = DirHandle->new($packagedir)
4819             or Carp::croak("Couldn't opendir $packagedir: $!");
4820         $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
4821         $mpldh->close;
4822     }
4823     my $prefer_installer = "eumm"; # eumm|mb
4824     if (-f File::Spec->catfile($packagedir,"Build.PL")) {
4825         if ($mpl_exists) { # they *can* choose
4826             if ($CPAN::META->has_inst("Module::Build")) {
4827                 $prefer_installer = $CPAN::Config->{prefer_installer};
4828             }
4829         } else {
4830             $prefer_installer = "mb";
4831         }
4832     }
4833     if (lc($prefer_installer) eq "mb") {
4834         $self->{modulebuild} = 1;
4835     } elsif (! $mpl_exists) {
4836         $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
4837                              $mpl,
4838                              CPAN::anycwd(),
4839                             )) if $CPAN::DEBUG;
4840         my($configure) = File::Spec->catfile($packagedir,"Configure");
4841         if (-f $configure) {
4842             # do we have anything to do?
4843             $self->{'configure'} = $configure;
4844         } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
4845             $CPAN::Frontend->mywarn(qq{
4846 Package comes with a Makefile and without a Makefile.PL.
4847 We\'ll try to build it with that Makefile then.
4848 });
4849             $self->{writemakefile} = CPAN::Distrostatus->new("YES");
4850             $CPAN::Frontend->mysleep(2);
4851         } else {
4852             my $cf = $self->called_for || "unknown";
4853             if ($cf =~ m|/|) {
4854                 $cf =~ s|.*/||;
4855                 $cf =~ s|\W.*||;
4856             }
4857             $cf =~ s|[/\\:]||g; # risk of filesystem damage
4858             $cf = "unknown" unless length($cf);
4859             $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
4860   (The test -f "$mpl" returned false.)
4861   Writing one on our own (setting NAME to $cf)\a\n});
4862             $self->{had_no_makefile_pl}++;
4863             $CPAN::Frontend->mysleep(3);
4864
4865             # Writing our own Makefile.PL
4866
4867             my $script = "";
4868             if ($self->{archived} eq "maybe_pl"){
4869                 my $fh = FileHandle->new;
4870                 my $script_file = File::Spec->catfile($packagedir,$local_file);
4871                 $fh->open($script_file)
4872                   or Carp::croak("Could not open $script_file: $!");
4873                 local $/ = "\n";
4874                 # name parsen und prereq
4875                 my($state) = "poddir";
4876                 my($name, $prereq) = ("", "");
4877                 while (<$fh>){
4878                     if ($state eq "poddir" && /^=head\d\s+(\S+)/) {
4879                         if ($1 eq 'NAME') {
4880                             $state = "name";
4881                         } elsif ($1 eq 'PREREQUISITES') {
4882                             $state = "prereq";
4883                         }
4884                     } elsif ($state =~ m{^(name|prereq)$}) {
4885                         if (/^=/) {
4886                             $state = "poddir";
4887                         } elsif (/^\s*$/) {
4888                             # nop
4889                         } elsif ($state eq "name") {
4890                             if ($name eq "") {
4891                                 ($name) = /^(\S+)/;
4892                                 $state = "poddir";
4893                             }
4894                         } elsif ($state eq "prereq") {
4895                             $prereq .= $_;
4896                         }
4897                     } elsif (/^=cut\b/) {
4898                         last;
4899                     }
4900                 }
4901                 $fh->close;
4902
4903                 for ($name) {
4904                     s{.*<}{}; # strip X<...>
4905                     s{>.*}{};
4906                 }
4907                 chomp $prereq;
4908                 $prereq = join " ", split /\s+/, $prereq;
4909                 my($PREREQ_PM) = join("\n", map {
4910                     s{.*<}{}; # strip X<...>
4911                     s{>.*}{};
4912                     if (/[\s\'\"]/) { # prose?
4913                     } else {
4914                         s/[^\w:]$//; # period?
4915                         " "x28 . "'$_' => 0,";
4916                     }
4917                 } split /\s*,\s*/, $prereq);
4918
4919                 $script = "
4920               EXE_FILES => ['$name'],
4921               PREREQ_PM => {
4922 $PREREQ_PM
4923                            },
4924 ";
4925
4926                 my $to_file = File::Spec->catfile($packagedir, $name);
4927                 rename $script_file, $to_file
4928                   or die "Can't rename $script_file to $to_file: $!";
4929             }
4930
4931             my $fh = FileHandle->new;
4932             $fh->open(">$mpl")
4933                 or Carp::croak("Could not open >$mpl: $!");
4934             $fh->print(
4935 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
4936 # because there was no Makefile.PL supplied.
4937 # Autogenerated on: }.scalar localtime().qq{
4938
4939 use ExtUtils::MakeMaker;
4940 WriteMakefile(
4941               NAME => q[$cf],$script
4942              );
4943 });
4944             $fh->close;
4945         }
4946     }
4947
4948     return $self;
4949 }
4950
4951 # CPAN::Distribution::untar_me ;
4952 sub untar_me {
4953     my($self,$ct) = @_;
4954     $self->{archived} = "tar";
4955     if ($ct->untar()) {
4956         $self->{unwrapped} = "YES";
4957     } else {
4958         $self->{unwrapped} = "NO";
4959     }
4960 }
4961
4962 # CPAN::Distribution::unzip_me ;
4963 sub unzip_me {
4964     my($self,$ct) = @_;
4965     $self->{archived} = "zip";
4966     if ($ct->unzip()) {
4967         $self->{unwrapped} = "YES";
4968     } else {
4969         $self->{unwrapped} = "NO";
4970     }
4971     return;
4972 }
4973
4974 sub handle_singlefile {
4975     my($self,$local_file) = @_;
4976
4977     if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ){
4978         $self->{archived} = "pm";
4979     } else {
4980         $self->{archived} = "maybe_pl";
4981     }
4982
4983     my $to = File::Basename::basename($local_file);
4984     if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
4985         if (CPAN::Tarzip->new($local_file)->gunzip($to)) {
4986             $self->{unwrapped} = "YES";
4987         } else {
4988             $self->{unwrapped} = "NO";
4989         }
4990     } else {
4991         File::Copy::cp($local_file,".");
4992         $self->{unwrapped} = "YES";
4993     }
4994     return $to;
4995 }
4996
4997 #-> sub CPAN::Distribution::new ;
4998 sub new {
4999     my($class,%att) = @_;
5000
5001     # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
5002
5003     my $this = { %att };
5004     return bless $this, $class;
5005 }
5006
5007 #-> sub CPAN::Distribution::look ;
5008 sub look {
5009     my($self) = @_;
5010
5011     if ($^O eq 'MacOS') {
5012       $self->Mac::BuildTools::look;
5013       return;
5014     }
5015
5016     if (  $CPAN::Config->{'shell'} ) {
5017         $CPAN::Frontend->myprint(qq{
5018 Trying to open a subshell in the build directory...
5019 });
5020     } else {
5021         $CPAN::Frontend->myprint(qq{
5022 Your configuration does not define a value for subshells.
5023 Please define it with "o conf shell <your shell>"
5024 });
5025         return;
5026     }
5027     my $dist = $self->id;
5028     my $dir;
5029     unless ($dir = $self->dir) {
5030         $self->get;
5031     }
5032     unless ($dir ||= $self->dir) {
5033         $CPAN::Frontend->mywarn(qq{
5034 Could not determine which directory to use for looking at $dist.
5035 });
5036         return;
5037     }
5038     my $pwd  = CPAN::anycwd();
5039     $self->safe_chdir($dir);
5040     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
5041     {
5042         local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
5043         $ENV{CPAN_SHELL_LEVEL} += 1;
5044         my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'});
5045         unless (system($shell) == 0) {
5046             my $code = $? >> 8;
5047             $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
5048         }
5049     }
5050     $self->safe_chdir($pwd);
5051 }
5052
5053 # CPAN::Distribution::cvs_import ;
5054 sub cvs_import {
5055     my($self) = @_;
5056     $self->get;
5057     my $dir = $self->dir;
5058
5059     my $package = $self->called_for;
5060     my $module = $CPAN::META->instance('CPAN::Module', $package);
5061     my $version = $module->cpan_version;
5062
5063     my $userid = $self->cpan_userid;
5064
5065     my $cvs_dir = (split /\//, $dir)[-1];
5066     $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
5067     my $cvs_root =
5068       $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
5069     my $cvs_site_perl =
5070       $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
5071     if ($cvs_site_perl) {
5072         $cvs_dir = "$cvs_site_perl/$cvs_dir";
5073     }
5074     my $cvs_log = qq{"imported $package $version sources"};
5075     $version =~ s/\./_/g;
5076     # XXX cvs
5077     my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
5078                "$cvs_dir", $userid, "v$version");
5079
5080     my $pwd  = CPAN::anycwd();
5081     chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
5082
5083     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
5084
5085     $CPAN::Frontend->myprint(qq{@cmd\n});
5086     system(@cmd) == 0 or
5087     # XXX cvs
5088         $CPAN::Frontend->mydie("cvs import failed");
5089     chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
5090 }
5091
5092 #-> sub CPAN::Distribution::readme ;
5093 sub readme {
5094     my($self) = @_;
5095     my($dist) = $self->id;
5096     my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
5097     $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
5098     my($local_file);
5099     my($local_wanted) =
5100          File::Spec->catfile(
5101                              $CPAN::Config->{keep_source_where},
5102                              "authors",
5103                              "id",
5104                              split(/\//,"$sans.readme"),
5105                             );
5106     $self->debug("Doing localize") if $CPAN::DEBUG;
5107     $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
5108                                       $local_wanted)
5109         or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
5110
5111     if ($^O eq 'MacOS') {
5112         Mac::BuildTools::launch_file($local_file);
5113         return;
5114     }
5115
5116     my $fh_pager = FileHandle->new;
5117     local($SIG{PIPE}) = "IGNORE";
5118     my $pager = $CPAN::Config->{'pager'} || "cat";
5119     $fh_pager->open("|$pager")
5120         or die "Could not open pager $pager\: $!";
5121     my $fh_readme = FileHandle->new;
5122     $fh_readme->open($local_file)
5123         or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
5124     $CPAN::Frontend->myprint(qq{
5125 Displaying file
5126   $local_file
5127 with pager "$pager"
5128 });
5129     $fh_pager->print(<$fh_readme>);
5130     $fh_pager->close;
5131 }
5132
5133 #-> sub CPAN::Distribution::verifyCHECKSUM ;
5134 sub verifyCHECKSUM {
5135     my($self) = @_;
5136   EXCUSE: {
5137         my @e;
5138         $self->{CHECKSUM_STATUS} ||= "";
5139         $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
5140         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
5141     }
5142     my($lc_want,$lc_file,@local,$basename);
5143     @local = split(/\//,$self->id);
5144     pop @local;
5145     push @local, "CHECKSUMS";
5146     $lc_want =
5147         File::Spec->catfile($CPAN::Config->{keep_source_where},
5148                             "authors", "id", @local);
5149     local($") = "/";
5150     if (my $size = -s $lc_want) {
5151         $self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG;
5152         if ($self->CHECKSUM_check_file($lc_want,1)) {
5153             return $self->{CHECKSUM_STATUS} = "OK";
5154         }
5155     }
5156     $lc_file = CPAN::FTP->localize("authors/id/@local",
5157                                    $lc_want,1);
5158     unless ($lc_file) {
5159         $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
5160         $local[-1] .= ".gz";
5161         $lc_file = CPAN::FTP->localize("authors/id/@local",
5162                                        "$lc_want.gz",1);
5163         if ($lc_file) {
5164             $lc_file =~ s/\.gz(?!\n)\Z//;
5165             CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file);
5166         } else {
5167             return;
5168         }
5169     }
5170     if ($self->CHECKSUM_check_file($lc_file)) {
5171         return $self->{CHECKSUM_STATUS} = "OK";
5172     }
5173 }
5174
5175 #-> sub CPAN::Distribution::SIG_check_file ;
5176 sub SIG_check_file {
5177     my($self,$chk_file) = @_;
5178     my $rv = eval { Module::Signature::_verify($chk_file) };
5179
5180     if ($rv == Module::Signature::SIGNATURE_OK()) {
5181         $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
5182         return $self->{SIG_STATUS} = "OK";
5183     } else {
5184         $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
5185                                  qq{distribution file. }.
5186                                  qq{Please investigate.\n\n}.
5187                                  $self->as_string,
5188                                 $CPAN::META->instance(
5189                                                         'CPAN::Author',
5190                                                         $self->cpan_userid
5191                                                         )->as_string);
5192
5193         my $wrap = qq{I\'d recommend removing $chk_file. Its signature
5194 is invalid. Maybe you have configured your 'urllist' with
5195 a bad URL. Please check this array with 'o conf urllist', and
5196 retry.};
5197
5198         $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
5199     }
5200 }
5201
5202 #-> sub CPAN::Distribution::CHECKSUM_check_file ;
5203
5204 # sloppy is 1 when we have an old checksums file that maybe is good
5205 # enough
5206
5207 sub CHECKSUM_check_file {
5208     my($self,$chk_file,$sloppy) = @_;
5209     my($cksum,$file,$basename);
5210
5211     $sloppy ||= 0;
5212     $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG;
5213     if ($CPAN::Config->{check_sigs}) {
5214         if ($CPAN::META->has_inst("Module::Signature") and Module::Signature->VERSION >= 0.26) {
5215             $self->debug("Module::Signature is installed, verifying");
5216             $self->SIG_check_file($chk_file);
5217         } else {
5218             $self->debug("Module::Signature is NOT installed");
5219         }
5220     }
5221
5222     $file = $self->{localfile};
5223     $basename = File::Basename::basename($file);
5224     my $fh = FileHandle->new;
5225     if (open $fh, $chk_file){
5226         local($/);
5227         my $eval = <$fh>;
5228         $eval =~ s/\015?\012/\n/g;
5229         close $fh;
5230         my($comp) = Safe->new();
5231         $cksum = $comp->reval($eval);
5232         if ($@) {
5233             rename $chk_file, "$chk_file.bad";
5234             Carp::confess($@) if $@;
5235         }
5236     } else {
5237         Carp::carp "Could not open $chk_file for reading";
5238     }
5239
5240     if (! ref $cksum or ref $cksum ne "HASH") {
5241         $CPAN::Frontend->mywarn(qq{
5242 Warning: checksum file '$chk_file' broken.
5243
5244 When trying to read that file I expected to get a hash reference
5245 for further processing, but got garbage instead.
5246 });
5247         my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
5248         $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
5249         $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken";
5250         return;
5251     } elsif (exists $cksum->{$basename}{sha256}) {
5252         $self->debug("Found checksum for $basename:" .
5253                      "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
5254
5255         open($fh, $file);
5256         binmode $fh;
5257         my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
5258         $fh->close;
5259         $fh = CPAN::Tarzip->TIEHANDLE($file);
5260
5261         unless ($eq) {
5262           my $dg = Digest::SHA->new(256);
5263           my($data,$ref);
5264           $ref = \$data;
5265           while ($fh->READ($ref, 4096) > 0){
5266             $dg->add($data);
5267           }
5268           my $hexdigest = $dg->hexdigest;
5269           $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
5270         }
5271
5272         if ($eq) {
5273           $CPAN::Frontend->myprint("Checksum for $file ok\n");
5274           return $self->{CHECKSUM_STATUS} = "OK";
5275         } else {
5276             $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
5277                                      qq{distribution file. }.
5278                                      qq{Please investigate.\n\n}.
5279                                      $self->as_string,
5280                                      $CPAN::META->instance(
5281                                                            'CPAN::Author',
5282                                                            $self->cpan_userid
5283                                                           )->as_string);
5284
5285             my $wrap = qq{I\'d recommend removing $file. Its
5286 checksum is incorrect. Maybe you have configured your 'urllist' with
5287 a bad URL. Please check this array with 'o conf urllist', and
5288 retry.};
5289
5290             $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
5291
5292             # former versions just returned here but this seems a
5293             # serious threat that deserves a die
5294
5295             # $CPAN::Frontend->myprint("\n\n");
5296             # sleep 3;
5297             # return;
5298         }
5299         # close $fh if fileno($fh);
5300     } else {
5301         return if $sloppy;
5302         unless ($self->{CHECKSUM_STATUS}) {
5303             $CPAN::Frontend->mywarn(qq{
5304 Warning: No checksum for $basename in $chk_file.
5305
5306 The cause for this may be that the file is very new and the checksum
5307 has not yet been calculated, but it may also be that something is
5308 going awry right now.
5309 });
5310             my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes");
5311             $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
5312         }
5313         $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file";
5314         return;
5315     }
5316 }
5317
5318 #-> sub CPAN::Distribution::eq_CHECKSUM ;
5319 sub eq_CHECKSUM {
5320     my($self,$fh,$expect) = @_;
5321     if ($CPAN::META->has_inst("Digest::SHA")) {
5322         my $dg = Digest::SHA->new(256);
5323         my($data);
5324         while (read($fh, $data, 4096)){
5325             $dg->add($data);
5326         }
5327         my $hexdigest = $dg->hexdigest;
5328         # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
5329         return $hexdigest eq $expect;
5330     }
5331     return 1;
5332 }
5333
5334 #-> sub CPAN::Distribution::force ;
5335
5336 # Both CPAN::Modules and CPAN::Distributions know if "force" is in
5337 # effect by autoinspection, not by inspecting a global variable. One
5338 # of the reason why this was chosen to work that way was the treatment
5339 # of dependencies. They should not automatically inherit the force
5340 # status. But this has the downside that ^C and die() will return to
5341 # the prompt but will not be able to reset the force_update
5342 # attributes. We try to correct for it currently in the read_metadata
5343 # routine, and immediately before we check for a Signal. I hope this
5344 # works out in one of v1.57_53ff
5345
5346 # "Force get forgets previous error conditions"
5347
5348 #-> sub CPAN::Distribution::force ;
5349 sub force {
5350   my($self, $method) = @_;
5351   for my $att (qw(
5352   CHECKSUM_STATUS archived build_dir localfile make install unwrapped
5353   writemakefile modulebuild make_test
5354  )) {
5355     delete $self->{$att};
5356   }
5357   if ($method && $method =~ /make|test|install/) {
5358     $self->{"force_update"}++; # name should probably have been force_install
5359   }
5360 }
5361
5362 sub notest {
5363   my($self, $method) = @_;
5364   # warn "XDEBUG: set notest for $self $method";
5365   $self->{"notest"}++; # name should probably have been force_install
5366 }
5367
5368 sub unnotest {
5369   my($self) = @_;
5370   # warn "XDEBUG: deleting notest";
5371   delete $self->{'notest'};
5372 }
5373
5374 #-> sub CPAN::Distribution::unforce ;
5375 sub unforce {
5376   my($self) = @_;
5377   delete $self->{'force_update'};
5378 }
5379
5380 #-> sub CPAN::Distribution::isa_perl ;
5381 sub isa_perl {
5382   my($self) = @_;
5383   my $file = File::Basename::basename($self->id);
5384   if ($file =~ m{ ^ perl
5385                   -?
5386                   (5)
5387                   ([._-])
5388                   (
5389                    \d{3}(_[0-4][0-9])?
5390                    |
5391                    \d+\.\d+
5392                   )
5393                   \.tar[._-]gz
5394                   (?!\n)\Z
5395                 }xs){
5396     return "$1.$3";
5397   } elsif ($self->cpan_comment
5398            &&
5399            $self->cpan_comment =~ /isa_perl\(.+?\)/){
5400     return $1;
5401   }
5402 }
5403
5404
5405 #-> sub CPAN::Distribution::perl ;
5406 sub perl {
5407     my ($self) = @_;
5408     if (! $self) {
5409         use Carp qw(carp);
5410         carp __PACKAGE__ . "::perl was called without parameters.";
5411     }
5412     return CPAN::HandleConfig->safe_quote($CPAN::Perl);
5413 }
5414
5415
5416 #-> sub CPAN::Distribution::make ;
5417 sub make {
5418     my($self) = @_;
5419     my $make = $self->{modulebuild} ? "Build" : "make";
5420     $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
5421     # Emergency brake if they said install Pippi and get newest perl
5422     if ($self->isa_perl) {
5423       if (
5424           $self->called_for ne $self->id &&
5425           ! $self->{force_update}
5426          ) {
5427         # if we die here, we break bundles
5428         $CPAN::Frontend->mywarn(sprintf qq{
5429 The most recent version "%s" of the module "%s"
5430 comes with the current version of perl (%s).
5431 I\'ll build that only if you ask for something like
5432     force install %s
5433 or
5434     install %s
5435 },
5436                                $CPAN::META->instance(
5437                                                      'CPAN::Module',
5438                                                      $self->called_for
5439                                                     )->cpan_version,
5440                                $self->called_for,
5441                                $self->isa_perl,
5442                                $self->called_for,
5443                                $self->id);
5444         $self->{make} = CPAN::Distrostatus->new("NO isa perl");
5445         $CPAN::Frontend->mysleep(1);
5446         return;
5447       }
5448     }
5449     $self->get;
5450     if ($CPAN::Signal){
5451       delete $self->{force_update};
5452       return;
5453     }
5454   EXCUSE: {
5455         my @e;
5456         !$self->{archived} || $self->{archived} eq "NO" and push @e,
5457         "Is neither a tar nor a zip archive.";
5458
5459         !$self->{unwrapped} || $self->{unwrapped} eq "NO" and push @e,
5460         "Had problems unarchiving. Please build manually";
5461
5462         unless ($self->{force_update}) {
5463             exists $self->{signature_verify} and (
5464                          $self->{signature_verify}->can("failed") ?
5465                          $self->{signature_verify}->failed :
5466                          $self->{signature_verify} =~ /^NO/
5467                         )
5468                 and push @e, "Did not pass the signature test.";
5469         }
5470
5471         if (exists $self->{writemakefile} &&
5472             (
5473              $self->{writemakefile}->can("failed") ?
5474              $self->{writemakefile}->failed :
5475              $self->{writemakefile} =~ /^NO/
5476             )) {
5477             # XXX maybe a retry would be in order?
5478             my $err = $self->{writemakefile}->can("text") ?
5479                 $self->{writemakefile}->text :
5480                     $self->{writemakefile};
5481             $err =~ s/^NO\s*//;
5482             $err ||= "Had some problem writing Makefile";
5483             $err .= ", won't make";
5484             push @e, $err;
5485         }
5486
5487         defined $self->{make} and push @e,
5488             "Has already been processed within this session";
5489
5490         if (exists $self->{later} and length($self->{later})) {
5491             if ($self->unsat_prereq) {
5492                 push @e, $self->{later};
5493 # RT ticket 18438 raises doubts if the deletion of {later} is valid.
5494 # YAML-0.53 triggered the later hodge-podge here, but my margin notes
5495 # are not sufficient to be sure if we really must/may do the delete
5496 # here. SO I accept the suggested patch for now. If we trigger a bug
5497 # again, I must go into deep contemplation about the {later} flag.
5498
5499 #            } else {
5500 #                delete $self->{later};
5501             }
5502         }
5503
5504         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
5505     }
5506     if ($CPAN::Signal){
5507       delete $self->{force_update};
5508       return;
5509     }
5510     $CPAN::Frontend->myprint("\n  CPAN.pm: Going to build ".$self->id."\n\n");
5511     my $builddir = $self->dir or
5512         $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
5513     chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
5514     $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
5515
5516     if ($^O eq 'MacOS') {
5517         Mac::BuildTools::make($self);
5518         return;
5519     }
5520
5521     my $system;
5522     if ($self->{'configure'}) {
5523         $system = $self->{'configure'};
5524     } elsif ($self->{modulebuild}) {
5525         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
5526         $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}";
5527     } else {
5528         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
5529         my $switch = "";
5530 # This needs a handler that can be turned on or off:
5531 #       $switch = "-MExtUtils::MakeMaker ".
5532 #           "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
5533 #           if $] > 5.00310;
5534         $system = sprintf("%s%s Makefile.PL%s",
5535                           $perl,
5536                           $switch ? " $switch" : "",
5537                           $CPAN::Config->{makepl_arg} ? " $CPAN::Config->{makepl_arg}" : "",
5538                          );
5539     }
5540     unless (exists $self->{writemakefile}) {
5541         local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
5542         my($ret,$pid);
5543         $@ = "";
5544         if ($CPAN::Config->{inactivity_timeout}) {
5545             eval {
5546                 alarm $CPAN::Config->{inactivity_timeout};
5547                 local $SIG{CHLD}; # = sub { wait };
5548                 if (defined($pid = fork)) {
5549                     if ($pid) { #parent
5550                         # wait;
5551                         waitpid $pid, 0;
5552                     } else {    #child
5553                         # note, this exec isn't necessary if
5554                         # inactivity_timeout is 0. On the Mac I'd
5555                         # suggest, we set it always to 0.
5556                         exec $system;
5557                     }
5558                 } else {
5559                     $CPAN::Frontend->myprint("Cannot fork: $!");
5560                     return;
5561                 }
5562             };
5563             alarm 0;
5564             if ($@){
5565                 kill 9, $pid;
5566                 waitpid $pid, 0;
5567                 my $err = "$@";
5568                 $CPAN::Frontend->myprint($err);
5569                 $self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
5570                 $@ = "";
5571                 return;
5572             }
5573         } else {
5574           $ret = system($system);
5575           if ($ret != 0) {
5576             $self->{writemakefile} = CPAN::Distrostatus
5577                 ->new("NO '$system' returned status $ret");
5578             $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
5579             return;
5580           }
5581         }
5582         if (-f "Makefile" || -f "Build") {
5583           $self->{writemakefile} = CPAN::Distrostatus->new("YES");
5584           delete $self->{make_clean}; # if cleaned before, enable next
5585         } else {
5586           $self->{writemakefile} = CPAN::Distrostatus
5587               ->new(qq{NO -- Unknown reason.});
5588         }
5589     }
5590     if ($CPAN::Signal){
5591       delete $self->{force_update};
5592       return;
5593     }
5594     if (my @prereq = $self->unsat_prereq){
5595       return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
5596     }
5597     if ($self->{modulebuild}) {
5598         unless (-f "Build") {
5599             my $cwd = Cwd::cwd;
5600             $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
5601                                     " in cwd[$cwd]. Danger, Will Robinson!");
5602             $CPAN::Frontend->mysleep(5);
5603         }
5604         $system = sprintf "%s %s", $self->_build_command(), $CPAN::Config->{mbuild_arg};
5605     } else {
5606         $system = join " ", $self->_make_command(), $CPAN::Config->{make_arg};
5607     }
5608     if (system($system) == 0) {
5609          $CPAN::Frontend->myprint("  $system -- OK\n");
5610          $self->{make} = CPAN::Distrostatus->new("YES");
5611     } else {
5612          $self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
5613          $self->{make} = CPAN::Distrostatus->new("NO");
5614          $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
5615     }
5616 }
5617
5618 sub _make_command {
5619     my ($self) = @_;
5620     if ($self) {
5621         return
5622           CPAN::HandleConfig
5623                 ->safe_quote(
5624                              $CPAN::Config->{make} || $Config::Config{make} || 'make'
5625                             );
5626     } else {
5627         # Old style call, without object. Deprecated
5628         Carp::confess("CPAN::_make_command() used as function. Don't Do That.");
5629         return
5630           safe_quote(undef, $CPAN::Config->{make} || $Config::Config{make} || 'make');
5631     }
5632 }
5633
5634 #-> sub CPAN::Distribution::follow_prereqs ;
5635 sub follow_prereqs {
5636     my($self) = shift;
5637     my(@prereq) = grep {$_ ne "perl"} @_;
5638     return unless @prereq;
5639     my $id = $self->id;
5640     $CPAN::Frontend->myprint("---- Unsatisfied dependencies detected ".
5641                              "during [$id] -----\n");
5642
5643     for my $p (@prereq) {
5644         $CPAN::Frontend->myprint("    $p\n");
5645     }
5646     my $follow = 0;
5647     if ($CPAN::Config->{prerequisites_policy} eq "follow") {
5648         $follow = 1;
5649     } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
5650         my $answer = CPAN::Shell::colorable_makemaker_prompt(
5651 "Shall I follow them and prepend them to the queue
5652 of modules we are processing right now?", "yes");
5653         $follow = $answer =~ /^\s*y/i;
5654     } else {
5655         local($") = ", ";
5656         $CPAN::Frontend->
5657             myprint("  Ignoring dependencies on modules @prereq\n");
5658     }
5659     if ($follow) {
5660         # color them as dirty
5661         for my $p (@prereq) {
5662             # warn "calling color_cmd_tmps(0,1)";
5663             CPAN::Shell->expandany($p)->color_cmd_tmps(0,1);
5664         }
5665         CPAN::Queue->jumpqueue(@prereq,$id); # queue them and requeue yourself
5666         $self->{later} = "Delayed until after prerequisites";
5667         return 1; # signal success to the queuerunner
5668     }
5669 }
5670
5671 #-> sub CPAN::Distribution::unsat_prereq ;
5672 sub unsat_prereq {
5673     my($self) = @_;
5674     my $prereq_pm = $self->prereq_pm or return;
5675     my(@need);
5676   NEED: while (my($need_module, $need_version) = each %$prereq_pm) {
5677         my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
5678         # we were too demanding:
5679         next if $nmo->uptodate;
5680
5681         # if they have not specified a version, we accept any installed one
5682         if (not defined $need_version or
5683            $need_version eq "0" or
5684            $need_version eq "undef") {
5685             next if defined $nmo->inst_file;
5686         }
5687
5688         # We only want to install prereqs if either they're not installed
5689         # or if the installed version is too old. We cannot omit this
5690         # check, because if 'force' is in effect, nobody else will check.
5691         if (defined $nmo->inst_file) {
5692             my(@all_requirements) = split /\s*,\s*/, $need_version;
5693             local($^W) = 0;
5694             my $ok = 0;
5695           RQ: for my $rq (@all_requirements) {
5696                 if ($rq =~ s|>=\s*||) {
5697                 } elsif ($rq =~ s|>\s*||) {
5698                     # 2005-12: one user
5699                     if (CPAN::Version->vgt($nmo->inst_version,$rq)){
5700                         $ok++;
5701                     }
5702                     next RQ;
5703                 } elsif ($rq =~ s|!=\s*||) {
5704                     # 2005-12: no user
5705                     if (CPAN::Version->vcmp($nmo->inst_version,$rq)){
5706                         $ok++;
5707                         next RQ;
5708                     } else {
5709                         last RQ;
5710                     }
5711                 } elsif ($rq =~ m|<=?\s*|) {
5712                     # 2005-12: no user
5713                     $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])");
5714                     $ok++;
5715                     next RQ;
5716                 }
5717                 if (! CPAN::Version->vgt($rq, $nmo->inst_version)){
5718                     $ok++;
5719                 }
5720                 CPAN->debug(sprintf "id[%s]inst_file[%s]inst_version[%s]rq[%s]ok[%d]",
5721                             $nmo->id,
5722                             $nmo->inst_file,
5723                             $nmo->inst_version,
5724                             CPAN::Version->readable($rq),
5725                             $ok,
5726                            ) if $CPAN::DEBUG;
5727             }
5728             next NEED if $ok == @all_requirements;
5729         }
5730
5731         if ($self->{sponsored_mods}{$need_module}++){
5732             # We have already sponsored it and for some reason it's still
5733             # not available. So we do nothing. Or what should we do?
5734             # if we push it again, we have a potential infinite loop
5735             next;
5736         }
5737         push @need, $need_module;
5738     }
5739     @need;
5740 }
5741
5742 #-> sub CPAN::Distribution::read_yaml ;
5743 sub read_yaml {
5744     my($self) = @_;
5745     return $self->{yaml_content} if exists $self->{yaml_content};
5746     my $build_dir = $self->{build_dir};
5747     my $yaml = File::Spec->catfile($build_dir,"META.yml");
5748     $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
5749     return unless -f $yaml;
5750     if ($CPAN::META->has_inst("YAML")) {
5751         eval { $self->{yaml_content} = YAML::LoadFile($yaml); };
5752         if ($@) {
5753             $CPAN::Frontend->mywarn("Error while parsing META.yml: $@");
5754             return;
5755         }
5756         if (not exists $self->{yaml_content}{dynamic_config}
5757             or $self->{yaml_content}{dynamic_config}
5758            ) {
5759             $self->{yaml_content} = undef;
5760         }
5761     }
5762     $self->debug("yaml_content[$self->{yaml_content}]") if $CPAN::DEBUG;
5763     return $self->{yaml_content};
5764 }
5765
5766 #-> sub CPAN::Distribution::prereq_pm ;
5767 sub prereq_pm {
5768     my($self) = @_;
5769     return $self->{prereq_pm} if
5770         exists $self->{prereq_pm_detected} && $self->{prereq_pm_detected};
5771     return unless $self->{writemakefile}  # no need to have succeeded
5772                                           # but we must have run it
5773         || $self->{modulebuild};
5774     my $req;
5775     if (my $yaml = $self->read_yaml) {
5776         $req =  $yaml->{requires};
5777         undef $req unless ref $req eq "HASH" && %$req;
5778         if ($req) {
5779             if ($yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
5780                 my $eummv = do { local $^W = 0; $1+0; };
5781                 if ($eummv < 6.2501) {
5782                     # thanks to Slaven for digging that out: MM before
5783                     # that could be wrong because it could reflect a
5784                     # previous release
5785                     undef $req;
5786                 }
5787             }
5788             my $areq;
5789             my $do_replace;
5790             while (my($k,$v) = each %{$req||{}}) {
5791                 if ($v =~ /\d/) {
5792                     $areq->{$k} = $v;
5793                 } elsif ($k =~ /[A-Za-z]/ &&
5794                          $v =~ /[A-Za-z]/ &&
5795                          $CPAN::META->exists("Module",$v)
5796                         ) {
5797                     $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
5798                                             "requires hash: $k => $v; I'll take both ".
5799                                             "key and value as a module name\n");
5800                     $CPAN::Frontend->mysleep(1);
5801                     $areq->{$k} = 0;
5802                     $areq->{$v} = 0;
5803                     $do_replace++;
5804                 }
5805             }
5806             $req = $areq if $do_replace;
5807         }
5808         if ($yaml->{build_requires}
5809             && ref $yaml->{build_requires}
5810             && ref $yaml->{build_requires} eq "HASH") {
5811             while (my($k,$v) = each %{$yaml->{build_requires}}) {
5812                 if ($req->{$k}) {
5813                     # merging of two "requires"-type values--what should we do?
5814                 } else {
5815                     $req->{$k} = $v;
5816                 }
5817             }
5818         }
5819         if ($req) {
5820             delete $req->{perl};
5821         }
5822     }
5823     unless ($req) {
5824         my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
5825         my $makefile = File::Spec->catfile($build_dir,"Makefile");
5826         my $fh;
5827         if (-f $makefile
5828             and
5829             $fh = FileHandle->new("<$makefile\0")) {
5830             local($/) = "\n";
5831             while (<$fh>) {
5832                 last if /MakeMaker post_initialize section/;
5833                 my($p) = m{^[\#]
5834                            \s+PREREQ_PM\s+=>\s+(.+)
5835                        }x;
5836                 next unless $p;
5837                 # warn "Found prereq expr[$p]";
5838
5839                 #  Regexp modified by A.Speer to remember actual version of file
5840                 #  PREREQ_PM hash key wants, then add to
5841                 while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
5842                     # In case a prereq is mentioned twice, complain.
5843                     if ( defined $req->{$1} ) {
5844                         warn "Warning: PREREQ_PM mentions $1 more than once, ".
5845                             "last mention wins";
5846                     }
5847                     $req->{$1} = $2;
5848                 }
5849                 last;
5850             }
5851         } elsif (-f "Build") {
5852             if ($CPAN::META->has_inst("Module::Build")) {
5853                 my $requires  = Module::Build->current->requires();
5854                 my $brequires = Module::Build->current->build_requires();
5855                 $req = { %$requires, %$brequires };
5856             }
5857         }
5858     }
5859     if (-f "Build.PL" && ! -f "Makefile.PL" && ! exists $req->{"Module::Build"}) {
5860         $CPAN::Frontend->mywarn("  Warning: CPAN.pm discovered Module::Build as ".
5861                                 "undeclared prerequisite.\n".
5862                                 "  Adding it now as a prerequisite.\n"
5863                                );
5864         $CPAN::Frontend->mysleep(5);
5865         $req->{"Module::Build"} = 0;
5866         delete $self->{writemakefile};
5867     }
5868     $self->{prereq_pm_detected}++;
5869     return $self->{prereq_pm} = $req;
5870 }
5871
5872 #-> sub CPAN::Distribution::test ;
5873 sub test {
5874     my($self) = @_;
5875     $self->make;
5876     if ($CPAN::Signal){
5877       delete $self->{force_update};
5878       return;
5879     }
5880     # warn "XDEBUG: checking for notest: $self->{notest} $self";
5881     if ($self->{notest}) {
5882         $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
5883         return 1;
5884     }
5885
5886     my $make = $self->{modulebuild} ? "Build" : "make";
5887     $CPAN::Frontend->myprint("Running $make test\n");
5888     if (my @prereq = $self->unsat_prereq){
5889       return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
5890     }
5891   EXCUSE: {
5892         my @e;
5893         unless (exists $self->{make} or exists $self->{later}) {
5894             push @e,
5895                 "Make had some problems, won't test";
5896         }
5897
5898         exists $self->{make} and
5899             (
5900              $self->{make}->can("failed") ?
5901              $self->{make}->failed :
5902              $self->{make} =~ /^NO/
5903             ) and push @e, "Can't test without successful make";
5904
5905         exists $self->{build_dir} or push @e, "Has no own directory";
5906         $self->{badtestcnt} ||= 0;
5907         $self->{badtestcnt} > 0 and
5908             push @e, "Won't repeat unsuccessful test during this command";
5909
5910         exists $self->{later} and length($self->{later}) and
5911             push @e, $self->{later};
5912
5913         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
5914     }
5915     chdir $self->{'build_dir'} or
5916         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
5917     $self->debug("Changed directory to $self->{'build_dir'}")
5918         if $CPAN::DEBUG;
5919
5920     if ($^O eq 'MacOS') {
5921         Mac::BuildTools::make_test($self);
5922         return;
5923     }
5924
5925     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
5926                            ? $ENV{PERL5LIB}
5927                            : ($ENV{PERLLIB} || "");
5928
5929     $CPAN::META->set_perl5lib;
5930     local $ENV{MAKEFLAGS}; # protect us from outer make calls
5931
5932     my $system;
5933     if ($self->{modulebuild}) {
5934         $system = sprintf "%s test", $self->_build_command();
5935     } else {
5936         $system = join " ", $self->_make_command(), "test";
5937     }
5938     my $tests_ok;
5939     if ( $CPAN::Config->{test_report} &&
5940          $CPAN::META->has_inst("CPAN::Reporter") ) {
5941             $tests_ok = CPAN::Reporter::test($self, $system);
5942     } else {
5943             $tests_ok = system($system) == 0;
5944     }
5945     if ( $tests_ok ) {
5946          $CPAN::Frontend->myprint("  $system -- OK\n");
5947          $CPAN::META->is_tested($self->{'build_dir'});
5948          $self->{make_test} = CPAN::Distrostatus->new("YES");
5949     } else {
5950          $self->{make_test} = CPAN::Distrostatus->new("NO");
5951          $self->{badtestcnt}++;
5952          $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
5953     }
5954 }
5955
5956 #-> sub CPAN::Distribution::clean ;
5957 sub clean {
5958     my($self) = @_;
5959     my $make = $self->{modulebuild} ? "Build" : "make";
5960     $CPAN::Frontend->myprint("Running $make clean\n");
5961     unless (exists $self->{archived}) {
5962         $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped".
5963                                 "/untarred, nothing done\n");
5964         return 1;
5965     }
5966     unless (exists $self->{build_dir}) {
5967         $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
5968         return 1;
5969     }
5970   EXCUSE: {
5971         my @e;
5972         exists $self->{make_clean} and $self->{make_clean} eq "YES" and
5973             push @e, "make clean already called once";
5974         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
5975     }
5976     chdir $self->{'build_dir'} or
5977         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
5978     $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
5979
5980     if ($^O eq 'MacOS') {
5981         Mac::BuildTools::make_clean($self);
5982         return;
5983     }
5984
5985     my $system;
5986     if ($self->{modulebuild}) {
5987         unless (-f "Build") {
5988             my $cwd = Cwd::cwd;
5989             $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
5990                                     " in cwd[$cwd]. Danger, Will Robinson!");
5991             $CPAN::Frontend->mysleep(5);
5992         }
5993         $system = sprintf "%s clean", $self->_build_command();
5994     } else {
5995         $system  = join " ", $self->_make_command(), "clean";
5996     }
5997     if (system($system) == 0) {
5998       $CPAN::Frontend->myprint("  $system -- OK\n");
5999
6000       # $self->force;
6001
6002       # Jost Krieger pointed out that this "force" was wrong because
6003       # it has the effect that the next "install" on this distribution
6004       # will untar everything again. Instead we should bring the
6005       # object's state back to where it is after untarring.
6006
6007       for my $k (qw(
6008                     force_update
6009                     install
6010                     writemakefile
6011                     make
6012                     make_test
6013                    )) {
6014           delete $self->{$k};
6015       }
6016       $self->{make_clean} = CPAN::Distrostatus->new("YES");
6017
6018     } else {
6019       # Hmmm, what to do if make clean failed?
6020
6021       $self->{make_clean} = CPAN::Distrostatus->new("NO");
6022       $CPAN::Frontend->mywarn(qq{  $system -- NOT OK\n});
6023
6024       # 2006-02-27: seems silly to me to force a make now
6025       # $self->force("make"); # so that this directory won't be used again
6026
6027     }
6028 }
6029
6030 #-> sub CPAN::Distribution::install ;
6031 sub install {
6032     my($self) = @_;
6033     $self->test;
6034     if ($CPAN::Signal){
6035       delete $self->{force_update};
6036       return;
6037     }
6038     my $make = $self->{modulebuild} ? "Build" : "make";
6039     $CPAN::Frontend->myprint("Running $make install\n");
6040   EXCUSE: {
6041         my @e;
6042         exists $self->{build_dir} or push @e, "Has no own directory";
6043
6044         unless (exists $self->{make} or exists $self->{later}) {
6045             push @e,
6046                 "Make had some problems, won't install";
6047         }
6048
6049         exists $self->{make} and
6050             (
6051              $self->{make}->can("failed") ?
6052              $self->{make}->failed :
6053              $self->{make} =~ /^NO/
6054             ) and
6055                 push @e, "make had returned bad status, install seems impossible";
6056
6057         if (exists $self->{make_test} and
6058             (
6059              $self->{make_test}->can("failed") ?
6060              $self->{make_test}->failed :
6061              $self->{make_test} =~ /^NO/
6062             )){
6063             if ($self->{force_update}) {
6064                 $self->{make_test}->text("FAILED but failure ignored because ".
6065                                          "'force' in effect");
6066             } else {
6067                 push @e, "make test had returned bad status, ".
6068                     "won't install without force"
6069             }
6070         }
6071         if (exists $self->{'install'}) {
6072             if ($self->{'install'}->can("text") ?
6073                 $self->{'install'}->text eq "YES" :
6074                 $self->{'install'} =~ /^YES/
6075                ) {
6076                 push @e, "Already done";
6077             } else {
6078                 # comment in Todo on 2006-02-11; maybe retry?
6079                 push @e, "Already tried without success";
6080             }
6081         }
6082
6083         exists $self->{later} and length($self->{later}) and
6084             push @e, $self->{later};
6085
6086         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
6087     }
6088     chdir $self->{'build_dir'} or
6089         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
6090     $self->debug("Changed directory to $self->{'build_dir'}")
6091         if $CPAN::DEBUG;
6092
6093     if ($^O eq 'MacOS') {
6094         Mac::BuildTools::make_install($self);
6095         return;
6096     }
6097
6098     my $system;
6099     if ($self->{modulebuild}) {
6100         my($mbuild_install_build_command) =
6101             exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
6102                 $CPAN::Config->{mbuild_install_build_command} ?
6103                     $CPAN::Config->{mbuild_install_build_command} :
6104                         $self->_build_command();
6105         $system = sprintf("%s install %s",
6106                           $mbuild_install_build_command,
6107                           $CPAN::Config->{mbuild_install_arg},
6108                          );
6109     } else {
6110         my($make_install_make_command) = $CPAN::Config->{make_install_make_command} ||
6111             $self->_make_command();
6112         $system = sprintf("%s install %s",
6113                           $make_install_make_command,
6114                           $CPAN::Config->{make_install_arg},
6115                          );
6116     }
6117
6118     my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 ";
6119     my($pipe) = FileHandle->new("$system $stderr |");
6120     my($makeout) = "";
6121     while (<$pipe>){
6122         print $_; # intentionally NOT use Frontend->myprint because it
6123                   # looks irritating when we markup in color what we
6124                   # just pass through from an external program
6125         $makeout .= $_;
6126     }
6127     $pipe->close;
6128     if ($?==0) {
6129         $CPAN::Frontend->myprint("  $system -- OK\n");
6130         $CPAN::META->is_installed($self->{build_dir});
6131         return $self->{install} = CPAN::Distrostatus->new("YES");
6132     } else {
6133         $self->{install} = CPAN::Distrostatus->new("NO");
6134         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
6135         if (
6136             $makeout =~ /permission/s
6137             && $> > 0
6138             && (
6139                 ! $CPAN::Config->{make_install_make_command}
6140                 || $CPAN::Config->{make_install_make_command} eq $CPAN::Config->{make}
6141                )
6142            ) {
6143             $CPAN::Frontend->myprint(
6144                                      qq{----\n}.
6145                                      qq{  You may have to su }.
6146                                      qq{to root to install the package\n}.
6147                                      qq{  (Or you may want to run something like\n}.
6148                                      qq{    o conf make_install_make_command 'sudo make'\n}.
6149                                      qq{  to raise your permissions.}
6150                                     );
6151         }
6152     }
6153     delete $self->{force_update};
6154 }
6155
6156 #-> sub CPAN::Distribution::dir ;
6157 sub dir {
6158     shift->{'build_dir'};
6159 }
6160
6161 #-> sub CPAN::Distribution::perldoc ;
6162 sub perldoc {
6163     my($self) = @_;
6164
6165     my($dist) = $self->id;
6166     my $package = $self->called_for;
6167
6168     $self->_display_url( $CPAN::Defaultdocs . $package );
6169 }
6170
6171 #-> sub CPAN::Distribution::_check_binary ;
6172 sub _check_binary {
6173     my ($dist,$shell,$binary) = @_;
6174     my ($pid,$out);
6175
6176     $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
6177       if $CPAN::DEBUG;
6178
6179     local *README;
6180     $pid = open README, "which $binary|"
6181       or $CPAN::Frontend->mydie(qq{Could not fork 'which $binary': $!});
6182     while (<README>) {
6183         $out .= $_;
6184     }
6185     close README or die "Could not run 'which $binary': $!";
6186
6187     $CPAN::Frontend->myprint(qq{   + $out \n})
6188       if $CPAN::DEBUG && $out;
6189
6190     return $out;
6191 }
6192
6193 #-> sub CPAN::Distribution::_display_url ;
6194 sub _display_url {
6195     my($self,$url) = @_;
6196     my($res,$saved_file,$pid,$out);
6197
6198     $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
6199       if $CPAN::DEBUG;
6200
6201     # should we define it in the config instead?
6202     my $html_converter = "html2text";
6203
6204     my $web_browser = $CPAN::Config->{'lynx'} || undef;
6205     my $web_browser_out = $web_browser
6206       ? CPAN::Distribution->_check_binary($self,$web_browser)
6207         : undef;
6208
6209     if ($web_browser_out) {
6210         # web browser found, run the action
6211         my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
6212         $CPAN::Frontend->myprint(qq{system[$browser $url]})
6213           if $CPAN::DEBUG;
6214         $CPAN::Frontend->myprint(qq{
6215 Displaying URL
6216   $url
6217 with browser $browser
6218 });
6219         $CPAN::Frontend->mysleep(1);
6220         system("$browser $url");
6221         if ($saved_file) { 1 while unlink($saved_file) }
6222     } else {
6223         # web browser not found, let's try text only
6224         my $html_converter_out =
6225           CPAN::Distribution->_check_binary($self,$html_converter);
6226         $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out);
6227
6228         if ($html_converter_out ) {
6229             # html2text found, run it
6230             $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
6231             $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n})
6232                 unless defined($saved_file);
6233
6234             local *README;
6235             $pid = open README, "$html_converter $saved_file |"
6236               or $CPAN::Frontend->mydie(qq{
6237 Could not fork '$html_converter $saved_file': $!});
6238             my($fh,$filename);
6239             if ($CPAN::META->has_inst("File::Temp")) {
6240                 $fh = File::Temp->new(
6241                                       template => 'cpan_htmlconvert_XXXX',
6242                                       suffix => '.txt',
6243                                       unlink => 0,
6244                                      );
6245                 $filename = $fh->filename;
6246             } else {
6247                 $filename = "cpan_htmlconvert_$$.txt";
6248                 $fh = FileHandle->new();
6249                 open $fh, ">$filename" or die;
6250             }
6251             while (<README>) {
6252                 $fh->print($_);
6253             }
6254             close README or
6255                 $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
6256             my $tmpin = $fh->filename;
6257             $CPAN::Frontend->myprint(sprintf(qq{
6258 Run '%s %s' and
6259 saved output to %s\n},
6260                                              $html_converter,
6261                                              $saved_file,
6262                                              $tmpin,
6263                                             )) if $CPAN::DEBUG;
6264             close $fh;
6265             local *FH;
6266             open FH, $tmpin
6267                 or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
6268             my $fh_pager = FileHandle->new;
6269             local($SIG{PIPE}) = "IGNORE";
6270             my $pager = $CPAN::Config->{'pager'} || "cat";
6271             $fh_pager->open("|pager")
6272                 or $CPAN::Frontend->mydie(qq{
6273 Could not open pager $pager\: $!});
6274             $CPAN::Frontend->myprint(qq{
6275 Displaying URL
6276   $url
6277 with pager "$pager"
6278 });
6279             $CPAN::Frontend->mysleep(1);
6280             $fh_pager->print(<FH>);
6281             $fh_pager->close;
6282         } else {
6283             # coldn't find the web browser or html converter
6284             $CPAN::Frontend->myprint(qq{
6285 You need to install lynx or $html_converter to use this feature.});
6286         }
6287     }
6288 }
6289
6290 #-> sub CPAN::Distribution::_getsave_url ;
6291 sub _getsave_url {
6292     my($dist, $shell, $url) = @_;
6293
6294     $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
6295       if $CPAN::DEBUG;
6296
6297     my($fh,$filename);
6298     if ($CPAN::META->has_inst("File::Temp")) {
6299         $fh = File::Temp->new(
6300                               template => "cpan_getsave_url_XXXX",
6301                               suffix => ".html",
6302                               unlink => 0,
6303                              );
6304         $filename = $fh->filename;
6305     } else {
6306         $fh = FileHandle->new;
6307         $filename = "cpan_getsave_url_$$.html";
6308     }
6309     my $tmpin = $filename;
6310     if ($CPAN::META->has_usable('LWP')) {
6311         $CPAN::Frontend->myprint("Fetching with LWP:
6312   $url
6313 ");
6314         my $Ua;
6315         CPAN::LWP::UserAgent->config;
6316         eval { $Ua = CPAN::LWP::UserAgent->new; };
6317         if ($@) {
6318             $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
6319             return;
6320         } else {
6321             my($var);
6322             $Ua->proxy('http', $var)
6323                 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
6324             $Ua->no_proxy($var)
6325                 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
6326         }
6327
6328         my $req = HTTP::Request->new(GET => $url);
6329         $req->header('Accept' => 'text/html');
6330         my $res = $Ua->request($req);
6331         if ($res->is_success) {
6332             $CPAN::Frontend->myprint(" + request successful.\n")
6333                 if $CPAN::DEBUG;
6334             print $fh $res->content;
6335             close $fh;
6336             $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
6337                 if $CPAN::DEBUG;
6338             return $tmpin;
6339         } else {
6340             $CPAN::Frontend->myprint(sprintf(
6341                                              "LWP failed with code[%s], message[%s]\n",
6342                                              $res->code,
6343                                              $res->message,
6344                                             ));
6345             return;
6346         }
6347     } else {
6348         $CPAN::Frontend->mywarn("  LWP not available\n");
6349         return;
6350     }
6351 }
6352
6353 # sub CPAN::Distribution::_build_command
6354 sub _build_command {
6355     my($self) = @_;
6356     if ($^O eq "MSWin32") { # special code needed at least up to
6357                             # Module::Build 0.2611 and 0.2706; a fix
6358                             # in M:B has been promised 2006-01-30
6359
6360         my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
6361         return "$perl ./Build";
6362     }
6363     return "./Build";
6364 }
6365
6366 package CPAN::Bundle;
6367 use strict;
6368
6369 sub look {
6370     my $self = shift;
6371     $CPAN::Frontend->myprint($self->as_string);
6372 }
6373
6374 sub undelay {
6375     my $self = shift;
6376     delete $self->{later};
6377     for my $c ( $self->contains ) {
6378         my $obj = CPAN::Shell->expandany($c) or next;
6379         $obj->undelay;
6380     }
6381 }
6382
6383 # mark as dirty/clean
6384 #-> sub CPAN::Bundle::color_cmd_tmps ;
6385 sub color_cmd_tmps {
6386     my($self) = shift;
6387     my($depth) = shift || 0;
6388     my($color) = shift || 0;
6389     my($ancestors) = shift || [];
6390     # a module needs to recurse to its cpan_file, a distribution needs
6391     # to recurse into its prereq_pms, a bundle needs to recurse into its modules
6392
6393     return if exists $self->{incommandcolor}
6394         && $self->{incommandcolor}==$color;
6395     if ($depth>=100){
6396         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
6397     }
6398     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
6399
6400     for my $c ( $self->contains ) {
6401         my $obj = CPAN::Shell->expandany($c) or next;
6402         CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
6403         $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
6404     }
6405     if ($color==0) {
6406         delete $self->{badtestcnt};
6407     }
6408     $self->{incommandcolor} = $color;
6409 }
6410
6411 #-> sub CPAN::Bundle::as_string ;
6412 sub as_string {
6413     my($self) = @_;
6414     $self->contains;
6415     # following line must be "=", not "||=" because we have a moving target
6416     $self->{INST_VERSION} = $self->inst_version;
6417     return $self->SUPER::as_string;
6418 }
6419
6420 #-> sub CPAN::Bundle::contains ;
6421 sub contains {
6422     my($self) = @_;
6423     my($inst_file) = $self->inst_file || "";
6424     my($id) = $self->id;
6425     $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
6426     if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) {
6427         undef $inst_file;
6428     }
6429     unless ($inst_file) {
6430         # Try to get at it in the cpan directory
6431         $self->debug("no inst_file") if $CPAN::DEBUG;
6432         my $cpan_file;
6433         $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
6434               $cpan_file = $self->cpan_file;
6435         if ($cpan_file eq "N/A") {
6436             $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
6437   Maybe stale symlink? Maybe removed during session? Giving up.\n");
6438         }
6439         my $dist = $CPAN::META->instance('CPAN::Distribution',
6440                                          $self->cpan_file);
6441         $dist->get;
6442         $self->debug("id[$dist->{ID}]") if $CPAN::DEBUG;
6443         my($todir) = $CPAN::Config->{'cpan_home'};
6444         my(@me,$from,$to,$me);
6445         @me = split /::/, $self->id;
6446         $me[-1] .= ".pm";
6447         $me = File::Spec->catfile(@me);
6448         $from = $self->find_bundle_file($dist->{'build_dir'},join('/',@me));
6449         $to = File::Spec->catfile($todir,$me);
6450         File::Path::mkpath(File::Basename::dirname($to));
6451         File::Copy::copy($from, $to)
6452               or Carp::confess("Couldn't copy $from to $to: $!");
6453         $inst_file = $to;
6454     }
6455     my @result;
6456     my $fh = FileHandle->new;
6457     local $/ = "\n";
6458     open($fh,$inst_file) or die "Could not open '$inst_file': $!";
6459     my $in_cont = 0;
6460     $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
6461     while (<$fh>) {
6462         $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
6463             m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
6464         next unless $in_cont;
6465         next if /^=/;
6466         s/\#.*//;
6467         next if /^\s+$/;
6468         chomp;
6469         push @result, (split " ", $_, 2)[0];
6470     }
6471     close $fh;
6472     delete $self->{STATUS};
6473     $self->{CONTAINS} = \@result;
6474     $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
6475     unless (@result) {
6476         $CPAN::Frontend->mywarn(qq{
6477 The bundle file "$inst_file" may be a broken
6478 bundlefile. It seems not to contain any bundle definition.
6479 Please check the file and if it is bogus, please delete it.
6480 Sorry for the inconvenience.
6481 });
6482     }
6483     @result;
6484 }
6485
6486 #-> sub CPAN::Bundle::find_bundle_file
6487 # $where is in local format, $what is in unix format
6488 sub find_bundle_file {
6489     my($self,$where,$what) = @_;
6490     $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
6491 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
6492 ###    my $bu = File::Spec->catfile($where,$what);
6493 ###    return $bu if -f $bu;
6494     my $manifest = File::Spec->catfile($where,"MANIFEST");
6495     unless (-f $manifest) {
6496         require ExtUtils::Manifest;
6497         my $cwd = CPAN::anycwd();
6498         $self->safe_chdir($where);
6499         ExtUtils::Manifest::mkmanifest();
6500         $self->safe_chdir($cwd);
6501     }
6502     my $fh = FileHandle->new($manifest)
6503         or Carp::croak("Couldn't open $manifest: $!");
6504     local($/) = "\n";
6505     my $bundle_filename = $what;
6506     $bundle_filename =~ s|Bundle.*/||;
6507     my $bundle_unixpath;
6508     while (<$fh>) {
6509         next if /^\s*\#/;
6510         my($file) = /(\S+)/;
6511         if ($file =~ m|\Q$what\E$|) {
6512             $bundle_unixpath = $file;
6513             # return File::Spec->catfile($where,$bundle_unixpath); # bad
6514             last;
6515         }
6516         # retry if she managed to have no Bundle directory
6517         $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
6518     }
6519     return File::Spec->catfile($where, split /\//, $bundle_unixpath)
6520         if $bundle_unixpath;
6521     Carp::croak("Couldn't find a Bundle file in $where");
6522 }
6523
6524 # needs to work quite differently from Module::inst_file because of
6525 # cpan_home/Bundle/ directory and the possibility that we have
6526 # shadowing effect. As it makes no sense to take the first in @INC for
6527 # Bundles, we parse them all for $VERSION and take the newest.
6528
6529 #-> sub CPAN::Bundle::inst_file ;
6530 sub inst_file {
6531     my($self) = @_;
6532     my($inst_file);
6533     my(@me);
6534     @me = split /::/, $self->id;
6535     $me[-1] .= ".pm";
6536     my($incdir,$bestv);
6537     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
6538         my $bfile = File::Spec->catfile($incdir, @me);
6539         CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
6540         next unless -f $bfile;
6541         my $foundv = MM->parse_version($bfile);
6542         if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
6543             $self->{INST_FILE} = $bfile;
6544             $self->{INST_VERSION} = $bestv = $foundv;
6545         }
6546     }
6547     $self->{INST_FILE};
6548 }
6549
6550 #-> sub CPAN::Bundle::inst_version ;
6551 sub inst_version {
6552     my($self) = @_;
6553     $self->inst_file; # finds INST_VERSION as side effect
6554     $self->{INST_VERSION};
6555 }
6556
6557 #-> sub CPAN::Bundle::rematein ;
6558 sub rematein {
6559     my($self,$meth) = @_;
6560     $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
6561     my($id) = $self->id;
6562     Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
6563         unless $self->inst_file || $self->cpan_file;
6564     my($s,%fail);
6565     for $s ($self->contains) {
6566         my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
6567             $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
6568         if ($type eq 'CPAN::Distribution') {
6569             $CPAN::Frontend->mywarn(qq{
6570 The Bundle }.$self->id.qq{ contains
6571 explicitly a file $s.
6572 });
6573             $CPAN::Frontend->mysleep(3);
6574         }
6575         # possibly noisy action:
6576         $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
6577         my $obj = $CPAN::META->instance($type,$s);
6578         $obj->$meth();
6579         if ($obj->isa('CPAN::Bundle')
6580             &&
6581             exists $obj->{install_failed}
6582             &&
6583             ref($obj->{install_failed}) eq "HASH"
6584            ) {
6585           for (keys %{$obj->{install_failed}}) {
6586             $self->{install_failed}{$_} = undef; # propagate faiure up
6587                                                  # to me in a
6588                                                  # recursive call
6589             $fail{$s} = 1; # the bundle itself may have succeeded but
6590                            # not all children
6591           }
6592         } else {
6593           my $success;
6594           $success = $obj->can("uptodate") ? $obj->uptodate : 0;
6595           $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
6596           if ($success) {
6597             delete $self->{install_failed}{$s};
6598           } else {
6599             $fail{$s} = 1;
6600           }
6601         }
6602     }
6603
6604     # recap with less noise
6605     if ( $meth eq "install" ) {
6606         if (%fail) {
6607             require Text::Wrap;
6608             my $raw = sprintf(qq{Bundle summary:
6609 The following items in bundle %s had installation problems:},
6610                               $self->id
6611                              );
6612             $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
6613             $CPAN::Frontend->myprint("\n");
6614             my $paragraph = "";
6615             my %reported;
6616             for $s ($self->contains) {
6617               if ($fail{$s}){
6618                 $paragraph .= "$s ";
6619                 $self->{install_failed}{$s} = undef;
6620                 $reported{$s} = undef;
6621               }
6622             }
6623             my $report_propagated;
6624             for $s (sort keys %{$self->{install_failed}}) {
6625               next if exists $reported{$s};
6626               $paragraph .= "and the following items had problems
6627 during recursive bundle calls: " unless $report_propagated++;
6628               $paragraph .= "$s ";
6629             }
6630             $CPAN::Frontend->myprint(Text::Wrap::fill("  ","  ",$paragraph));
6631             $CPAN::Frontend->myprint("\n");
6632         } else {
6633             $self->{'install'} = 'YES';
6634         }
6635     }
6636 }
6637
6638 # If a bundle contains another that contains an xs_file we have here,
6639 # we just don't bother I suppose
6640 #-> sub CPAN::Bundle::xs_file
6641 sub xs_file {
6642     return 0;
6643 }
6644
6645 #-> sub CPAN::Bundle::force ;
6646 sub force   { shift->rematein('force',@_); }
6647 #-> sub CPAN::Bundle::notest ;
6648 sub notest  { shift->rematein('notest',@_); }
6649 #-> sub CPAN::Bundle::get ;
6650 sub get     { shift->rematein('get',@_); }
6651 #-> sub CPAN::Bundle::make ;
6652 sub make    { shift->rematein('make',@_); }
6653 #-> sub CPAN::Bundle::test ;
6654 sub test    {
6655     my $self = shift;
6656     $self->{badtestcnt} ||= 0;
6657     $self->rematein('test',@_);
6658 }
6659 #-> sub CPAN::Bundle::install ;
6660 sub install {
6661   my $self = shift;
6662   $self->rematein('install',@_);
6663 }
6664 #-> sub CPAN::Bundle::clean ;
6665 sub clean   { shift->rematein('clean',@_); }
6666
6667 #-> sub CPAN::Bundle::uptodate ;
6668 sub uptodate {
6669     my($self) = @_;
6670     return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
6671     my $c;
6672     foreach $c ($self->contains) {
6673         my $obj = CPAN::Shell->expandany($c);
6674         return 0 unless $obj->uptodate;
6675     }
6676     return 1;
6677 }
6678
6679 #-> sub CPAN::Bundle::readme ;
6680 sub readme  {
6681     my($self) = @_;
6682     my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
6683 No File found for bundle } . $self->id . qq{\n}), return;
6684     $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
6685     $CPAN::META->instance('CPAN::Distribution',$file)->readme;
6686 }
6687
6688 package CPAN::Module;
6689 use strict;
6690
6691 # Accessors
6692 # sub CPAN::Module::userid
6693 sub userid {
6694     my $self = shift;
6695     my $ro = $self->ro;
6696     return unless $ro;
6697     return $ro->{userid} || $ro->{CPAN_USERID};
6698 }
6699 # sub CPAN::Module::description
6700 sub description {
6701     my $self = shift;
6702     my $ro = $self->ro or return "";
6703     $ro->{description}
6704 }
6705
6706 sub distribution {
6707     my($self) = @_;
6708     CPAN::Shell->expand("Distribution",$self->cpan_file);
6709 }
6710
6711 # sub CPAN::Module::undelay
6712 sub undelay {
6713     my $self = shift;
6714     delete $self->{later};
6715     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
6716         $dist->undelay;
6717     }
6718 }
6719
6720 # mark as dirty/clean
6721 #-> sub CPAN::Module::color_cmd_tmps ;
6722 sub color_cmd_tmps {
6723     my($self) = shift;
6724     my($depth) = shift || 0;
6725     my($color) = shift || 0;
6726     my($ancestors) = shift || [];
6727     # a module needs to recurse to its cpan_file
6728
6729     return if exists $self->{incommandcolor}
6730         && $self->{incommandcolor}==$color;
6731     return if $depth>=1 && $self->uptodate;
6732     if ($depth>=100){
6733         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
6734     }
6735     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
6736
6737     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
6738         $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
6739     }
6740     if ($color==0) {
6741         delete $self->{badtestcnt};
6742     }
6743     $self->{incommandcolor} = $color;
6744 }
6745
6746 #-> sub CPAN::Module::as_glimpse ;
6747 sub as_glimpse {
6748     my($self) = @_;
6749     my(@m);
6750     my $class = ref($self);
6751     $class =~ s/^CPAN:://;
6752     my $color_on = "";
6753     my $color_off = "";
6754     if (
6755         $CPAN::Shell::COLOR_REGISTERED
6756         &&
6757         $CPAN::META->has_inst("Term::ANSIColor")
6758         &&
6759         $self->description
6760        ) {
6761         $color_on = Term::ANSIColor::color("green");
6762         $color_off = Term::ANSIColor::color("reset");
6763     }
6764     my $uptodateness = " ";
6765     if ($class eq "Bundle") {
6766     } elsif ($self->uptodate) {
6767         $uptodateness = "=";
6768     } elsif ($self->inst_version) {
6769         $uptodateness = "<";
6770     }
6771     push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n",
6772                      $class,
6773                      $uptodateness,
6774                      $color_on,
6775                      $self->id,
6776                      $color_off,
6777                      ($self->distribution ?
6778                       $self->distribution->pretty_id :
6779                       $self->cpan_userid
6780                      ),
6781                     );
6782     join "", @m;
6783 }
6784
6785 #-> sub CPAN::Module::dslip_status
6786 sub dslip_status {
6787     my($self) = @_;
6788     my($stat);
6789     @{$stat->{D}}{qw,i c a b R M S,}     = qw,idea
6790                                               pre-alpha alpha beta released
6791                                               mature standard,;
6792     @{$stat->{S}}{qw,m d u n a,}         = qw,mailing-list
6793                                               developer comp.lang.perl.*
6794                                               none abandoned,;
6795     @{$stat->{L}}{qw,p c + o h,}         = qw,perl C C++ other hybrid,;
6796     @{$stat->{I}}{qw,f r O p h n,}       = qw,functions
6797                                               references+ties
6798                                               object-oriented pragma
6799                                               hybrid none,;
6800     @{$stat->{P}}{qw,p g l b a o d r n,} = qw,Standard-Perl
6801                                               GPL LGPL
6802                                               BSD Artistic
6803                                               open-source
6804                                               distribution_allowed
6805                                               restricted_distribution
6806                                               no_licence,;
6807     for my $x (qw(d s l i p)) {
6808         $stat->{$x}{' '} = 'unknown';
6809         $stat->{$x}{'?'} = 'unknown';
6810     }
6811     my $ro = $self->ro;
6812     return +{} unless $ro && $ro->{statd};
6813     return {
6814             D  => $ro->{statd},
6815             S  => $ro->{stats},
6816             L  => $ro->{statl},
6817             I  => $ro->{stati},
6818             P  => $ro->{statp},
6819             DV => $stat->{D}{$ro->{statd}},
6820             SV => $stat->{S}{$ro->{stats}},
6821             LV => $stat->{L}{$ro->{statl}},
6822             IV => $stat->{I}{$ro->{stati}},
6823             PV => $stat->{P}{$ro->{statp}},
6824            };
6825 }
6826
6827 #-> sub CPAN::Module::as_string ;
6828 sub as_string {
6829     my($self) = @_;
6830     my(@m);
6831     CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
6832     my $class = ref($self);
6833     $class =~ s/^CPAN:://;
6834     local($^W) = 0;
6835     push @m, $class, " id = $self->{ID}\n";
6836     my $sprintf = "    %-12s %s\n";
6837     push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
6838         if $self->description;
6839     my $sprintf2 = "    %-12s %s (%s)\n";
6840     my($userid);
6841     $userid = $self->userid;
6842     if ( $userid ){
6843         my $author;
6844         if ($author = CPAN::Shell->expand('Author',$userid)) {
6845           my $email = "";
6846           my $m; # old perls
6847           if ($m = $author->email) {
6848             $email = " <$m>";
6849           }
6850           push @m, sprintf(
6851                            $sprintf2,
6852                            'CPAN_USERID',
6853                            $userid,
6854                            $author->fullname . $email
6855                           );
6856         }
6857     }
6858     push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
6859         if $self->cpan_version;
6860     if (my $cpan_file = $self->cpan_file){
6861         push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
6862         if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
6863             my $upload_date = $dist->upload_date;
6864             if ($upload_date) {
6865                 push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
6866             }
6867         }
6868     }
6869     my $sprintf3 = "    %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n";
6870     my $dslip = $self->dslip_status;
6871     push @m, sprintf(
6872                      $sprintf3,
6873                      'DSLIP_STATUS',
6874                      @{$dslip}{qw(D S L I P DV SV LV IV PV)},
6875                     ) if $dslip->{D};
6876     my $local_file = $self->inst_file;
6877     unless ($self->{MANPAGE}) {
6878         my $manpage;
6879         if ($local_file) {
6880             $manpage = $self->manpage_headline($local_file);
6881         } else {
6882             # If we have already untarred it, we should look there
6883             my $dist = $CPAN::META->instance('CPAN::Distribution',
6884                                              $self->cpan_file);
6885             # warn "dist[$dist]";
6886             # mff=manifest file; mfh=manifest handle
6887             my($mff,$mfh);
6888             if (
6889                 $dist->{build_dir}
6890                 and
6891                 (-f  ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
6892                 and
6893                 $mfh = FileHandle->new($mff)
6894                ) {
6895                 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
6896                 my $lfre = $self->id; # local file RE
6897                 $lfre =~ s/::/./g;
6898                 $lfre .= "\\.pm\$";
6899                 my($lfl); # local file file
6900                 local $/ = "\n";
6901                 my(@mflines) = <$mfh>;
6902                 for (@mflines) {
6903                     s/^\s+//;
6904                     s/\s.*//s;
6905                 }
6906                 while (length($lfre)>5 and !$lfl) {
6907                     ($lfl) = grep /$lfre/, @mflines;
6908                     CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
6909                     $lfre =~ s/.+?\.//;
6910                 }
6911                 $lfl =~ s/\s.*//; # remove comments
6912                 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
6913                 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
6914                 # warn "lfl_abs[$lfl_abs]";
6915                 if (-f $lfl_abs) {
6916                     $manpage = $self->manpage_headline($lfl_abs);
6917                 }
6918             }
6919         }
6920         $self->{MANPAGE} = $manpage if $manpage;
6921     }
6922     my($item);
6923     for $item (qw/MANPAGE/) {
6924         push @m, sprintf($sprintf, $item, $self->{$item})
6925             if exists $self->{$item};
6926     }
6927     for $item (qw/CONTAINS/) {
6928         push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
6929             if exists $self->{$item} && @{$self->{$item}};
6930     }
6931     push @m, sprintf($sprintf, 'INST_FILE',
6932                      $local_file || "(not installed)");
6933     push @m, sprintf($sprintf, 'INST_VERSION',
6934                      $self->inst_version) if $local_file;
6935     join "", @m, "\n";
6936 }
6937
6938 sub manpage_headline {
6939   my($self,$local_file) = @_;
6940   my(@local_file) = $local_file;
6941   $local_file =~ s/\.pm(?!\n)\Z/.pod/;
6942   push @local_file, $local_file;
6943   my(@result,$locf);
6944   for $locf (@local_file) {
6945     next unless -f $locf;
6946     my $fh = FileHandle->new($locf)
6947         or $Carp::Frontend->mydie("Couldn't open $locf: $!");
6948     my $inpod = 0;
6949     local $/ = "\n";
6950     while (<$fh>) {
6951       $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
6952           m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
6953       next unless $inpod;
6954       next if /^=/;
6955       next if /^\s+$/;
6956       chomp;
6957       push @result, $_;
6958     }
6959     close $fh;
6960     last if @result;
6961   }
6962   for (@result) {
6963       s/^\s+//;
6964       s/\s+$//;
6965   }
6966   join " ", @result;
6967 }
6968
6969 #-> sub CPAN::Module::cpan_file ;
6970 # Note: also inherited by CPAN::Bundle
6971 sub cpan_file {
6972     my $self = shift;
6973     CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
6974     unless ($self->ro) {
6975         CPAN::Index->reload;
6976     }
6977     my $ro = $self->ro;
6978     if ($ro && defined $ro->{CPAN_FILE}){
6979         return $ro->{CPAN_FILE};
6980     } else {
6981         my $userid = $self->userid;
6982         if ( $userid ) {
6983             if ($CPAN::META->exists("CPAN::Author",$userid)) {
6984                 my $author = $CPAN::META->instance("CPAN::Author",
6985                                                    $userid);
6986                 my $fullname = $author->fullname;
6987                 my $email = $author->email;
6988                 unless (defined $fullname && defined $email) {
6989                     return sprintf("Contact Author %s",
6990                                    $userid,
6991                                   );
6992                 }
6993                 return "Contact Author $fullname <$email>";
6994             } else {
6995                 return "Contact Author $userid (Email address not available)";
6996             }
6997         } else {
6998             return "N/A";
6999         }
7000     }
7001 }
7002
7003 #-> sub CPAN::Module::cpan_version ;
7004 sub cpan_version {
7005     my $self = shift;
7006
7007     my $ro = $self->ro;
7008     unless ($ro) {
7009         # Can happen with modules that are not on CPAN
7010         $ro = {};
7011     }
7012     $ro->{CPAN_VERSION} = 'undef'
7013         unless defined $ro->{CPAN_VERSION};
7014     $ro->{CPAN_VERSION};
7015 }
7016
7017 #-> sub CPAN::Module::force ;
7018 sub force {
7019     my($self) = @_;
7020     $self->{'force_update'}++;
7021 }
7022
7023 sub notest {
7024     my($self) = @_;
7025     # warn "XDEBUG: set notest for Module";
7026     $self->{'notest'}++;
7027 }
7028
7029 #-> sub CPAN::Module::rematein ;
7030 sub rematein {
7031     my($self,$meth) = @_;
7032     $CPAN::Frontend->myprint(sprintf("Running %s for module %s\n",
7033                                      $meth,
7034                                      $self->id));
7035     my $cpan_file = $self->cpan_file;
7036     if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
7037       $CPAN::Frontend->mywarn(sprintf qq{
7038   The module %s isn\'t available on CPAN.
7039
7040   Either the module has not yet been uploaded to CPAN, or it is
7041   temporary unavailable. Please contact the author to find out
7042   more about the status. Try 'i %s'.
7043 },
7044                               $self->id,
7045                               $self->id,
7046                              );
7047       return;
7048     }
7049     my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
7050     $pack->called_for($self->id);
7051     $pack->force($meth) if exists $self->{'force_update'};
7052     $pack->notest($meth) if exists $self->{'notest'};
7053     eval {
7054         $pack->$meth();
7055     };
7056     my $err = $@;
7057     $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
7058     $pack->unnotest if $pack->can("unnotest") && exists $self->{'notest'};
7059     delete $self->{'force_update'};
7060     delete $self->{'notest'};
7061     if ($err) {
7062         die $err;
7063     }
7064 }
7065
7066 #-> sub CPAN::Module::perldoc ;
7067 sub perldoc { shift->rematein('perldoc') }
7068 #-> sub CPAN::Module::readme ;
7069 sub readme  { shift->rematein('readme') }
7070 #-> sub CPAN::Module::look ;
7071 sub look    { shift->rematein('look') }
7072 #-> sub CPAN::Module::cvs_import ;
7073 sub cvs_import { shift->rematein('cvs_import') }
7074 #-> sub CPAN::Module::get ;
7075 sub get     { shift->rematein('get',@_) }
7076 #-> sub CPAN::Module::make ;
7077 sub make    { shift->rematein('make') }
7078 #-> sub CPAN::Module::test ;
7079 sub test   {
7080     my $self = shift;
7081     $self->{badtestcnt} ||= 0;
7082     $self->rematein('test',@_);
7083 }
7084 #-> sub CPAN::Module::uptodate ;
7085 sub uptodate {
7086     my($self) = @_;
7087     local($_); # protect against a bug in MakeMaker 6.17
7088     my($latest) = $self->cpan_version;
7089     $latest ||= 0;
7090     my($inst_file) = $self->inst_file;
7091     my($have) = 0;
7092     if (defined $inst_file) {
7093         $have = $self->inst_version;
7094     }
7095     local($^W)=0;
7096     if ($inst_file
7097         &&
7098         ! CPAN::Version->vgt($latest, $have)
7099        ) {
7100         CPAN->debug("returning uptodate. inst_file[$inst_file] ".
7101                     "latest[$latest] have[$have]") if $CPAN::DEBUG;
7102         return 1;
7103     }
7104     return;
7105 }
7106 #-> sub CPAN::Module::install ;
7107 sub install {
7108     my($self) = @_;
7109     my($doit) = 0;
7110     if ($self->uptodate
7111         &&
7112         not exists $self->{'force_update'}
7113        ) {
7114         $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
7115                                          $self->id,
7116                                          $self->inst_version,
7117                                         ));
7118     } else {
7119         $doit = 1;
7120     }
7121     my $ro = $self->ro;
7122     if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
7123         $CPAN::Frontend->mywarn(qq{
7124 \n\n\n     ***WARNING***
7125      The module $self->{ID} has no active maintainer.\n\n\n
7126 });
7127         $CPAN::Frontend->mysleep(5);
7128     }
7129     $self->rematein('install') if $doit;
7130 }
7131 #-> sub CPAN::Module::clean ;
7132 sub clean  { shift->rematein('clean') }
7133
7134 #-> sub CPAN::Module::inst_file ;
7135 sub inst_file {
7136     my($self) = @_;
7137     my($dir,@packpath);
7138     @packpath = split /::/, $self->{ID};
7139     $packpath[-1] .= ".pm";
7140     if (@packpath == 1 && $packpath[0] eq "readline.pm") {
7141         unshift @packpath, "Term", "ReadLine"; # historical reasons
7142     }
7143     foreach $dir (@INC) {
7144         my $pmfile = File::Spec->catfile($dir,@packpath);
7145         if (-f $pmfile){
7146             return $pmfile;
7147         }
7148     }
7149     return;
7150 }
7151
7152 #-> sub CPAN::Module::xs_file ;
7153 sub xs_file {
7154     my($self) = @_;
7155     my($dir,@packpath);
7156     @packpath = split /::/, $self->{ID};
7157     push @packpath, $packpath[-1];
7158     $packpath[-1] .= "." . $Config::Config{'dlext'};
7159     foreach $dir (@INC) {
7160         my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
7161         if (-f $xsfile){
7162             return $xsfile;
7163         }
7164     }
7165     return;
7166 }
7167
7168 #-> sub CPAN::Module::inst_version ;
7169 sub inst_version {
7170     my($self) = @_;
7171     my $parsefile = $self->inst_file or return;
7172     local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
7173     my $have;
7174
7175     $have = MM->parse_version($parsefile) || "undef";
7176     $have =~ s/^ //; # since the %vd hack these two lines here are needed
7177     $have =~ s/ $//; # trailing whitespace happens all the time
7178
7179     # My thoughts about why %vd processing should happen here
7180
7181     # Alt1 maintain it as string with leading v:
7182     # read index files     do nothing
7183     # compare it           use utility for compare
7184     # print it             do nothing
7185
7186     # Alt2 maintain it as what it is
7187     # read index files     convert
7188     # compare it           use utility because there's still a ">" vs "gt" issue
7189     # print it             use CPAN::Version for print
7190
7191     # Seems cleaner to hold it in memory as a string starting with a "v"
7192
7193     # If the author of this module made a mistake and wrote a quoted
7194     # "v1.13" instead of v1.13, we simply leave it at that with the
7195     # effect that *we* will treat it like a v-tring while the rest of
7196     # perl won't. Seems sensible when we consider that any action we
7197     # could take now would just add complexity.
7198
7199     $have = CPAN::Version->readable($have);
7200
7201     $have =~ s/\s*//g; # stringify to float around floating point issues
7202     $have; # no stringify needed, \s* above matches always
7203 }
7204
7205 package CPAN;
7206 use strict;
7207
7208 1;
7209
7210
7211 __END__
7212
7213 =head1 NAME
7214
7215 CPAN - query, download and build perl modules from CPAN sites
7216
7217 =head1 SYNOPSIS
7218
7219 Interactive mode:
7220
7221   perl -MCPAN -e shell;
7222
7223 Batch mode:
7224
7225   use CPAN;
7226
7227   # modules:
7228
7229   $mod = "Acme::Meta";
7230   install $mod;
7231   CPAN::Shell->install($mod);                    # same thing
7232   CPAN::Shell->expandany($mod)->install;         # same thing
7233   CPAN::Shell->expand("Module",$mod)->install;   # same thing
7234   CPAN::Shell->expand("Module",$mod)
7235     ->distribution->install;                     # same thing
7236
7237   # distributions:
7238
7239   $distro = "NWCLARK/Acme-Meta-0.01.tar.gz";
7240   install $distro;                                # same thing
7241   CPAN::Shell->install($distro);                  # same thing
7242   CPAN::Shell->expandany($distro)->install;       # same thing
7243   CPAN::Shell->expand("Distribution",$distro)->install; # same thing
7244
7245 =head1 STATUS
7246
7247 This module will eventually be replaced by CPANPLUS. CPANPLUS is kind
7248 of a modern rewrite from ground up with greater extensibility and more
7249 features but no full compatibility. If you're new to CPAN.pm, you
7250 probably should investigate if CPANPLUS is the better choice for you.
7251
7252 If you're already used to CPAN.pm you're welcome to continue using it.
7253 I intend to support it until somebody convinces me that there is a
7254 both superior and sufficiently compatible drop-in replacement.
7255
7256 =head1 COMPATIBILITY
7257
7258 CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted
7259 newer versions. It is getting more and more difficult to get the
7260 minimal prerequisites working on older perls. It is close to
7261 impossible to get the whole Bundle::CPAN working there. If you're in
7262 the position to have only these old versions, be advised that CPAN is
7263 designed to work fine without the Bundle::CPAN installed.
7264
7265 To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is
7266 compatible with ancient perls and that File::Temp is listed as a
7267 prerequisite but CPAN has reasonable workarounds if it is missing.
7268
7269 =head1 DESCRIPTION
7270
7271 The CPAN module is designed to automate the make and install of perl
7272 modules and extensions. It includes some primitive searching
7273 capabilities and knows how to use Net::FTP or LWP (or some external
7274 download clients) to fetch the raw data from the net.
7275
7276 Modules are fetched from one or more of the mirrored CPAN
7277 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
7278 directory.
7279
7280 The CPAN module also supports the concept of named and versioned
7281 I<bundles> of modules. Bundles simplify the handling of sets of
7282 related modules. See Bundles below.
7283
7284 The package contains a session manager and a cache manager. There is
7285 no status retained between sessions. The session manager keeps track
7286 of what has been fetched, built and installed in the current
7287 session. The cache manager keeps track of the disk space occupied by
7288 the make processes and deletes excess space according to a simple FIFO
7289 mechanism.
7290
7291 All methods provided are accessible in a programmer style and in an
7292 interactive shell style.
7293
7294 =head2 Interactive Mode
7295
7296 The interactive mode is entered by running
7297
7298     perl -MCPAN -e shell
7299
7300 which puts you into a readline interface. You will have the most fun if
7301 you install Term::ReadKey and Term::ReadLine to enjoy both history and
7302 command completion.
7303
7304 Once you are on the command line, type 'h' and the rest should be
7305 self-explanatory.
7306
7307 The function call C<shell> takes two optional arguments, one is the
7308 prompt, the second is the default initial command line (the latter
7309 only works if a real ReadLine interface module is installed).
7310
7311 The most common uses of the interactive modes are
7312
7313 =over 2
7314
7315 =item Searching for authors, bundles, distribution files and modules
7316
7317 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
7318 for each of the four categories and another, C<i> for any of the
7319 mentioned four. Each of the four entities is implemented as a class
7320 with slightly differing methods for displaying an object.
7321
7322 Arguments you pass to these commands are either strings exactly matching
7323 the identification string of an object or regular expressions that are
7324 then matched case-insensitively against various attributes of the
7325 objects. The parser recognizes a regular expression only if you
7326 enclose it between two slashes.
7327
7328 The principle is that the number of found objects influences how an
7329 item is displayed. If the search finds one item, the result is
7330 displayed with the rather verbose method C<as_string>, but if we find
7331 more than one, we display each object with the terse method
7332 C<as_glimpse>.
7333
7334 =item make, test, install, clean  modules or distributions
7335
7336 These commands take any number of arguments and investigate what is
7337 necessary to perform the action. If the argument is a distribution
7338 file name (recognized by embedded slashes), it is processed. If it is
7339 a module, CPAN determines the distribution file in which this module
7340 is included and processes that, following any dependencies named in
7341 the module's META.yml or Makefile.PL (this behavior is controlled by
7342 the configuration parameter C<prerequisites_policy>.)
7343
7344 Any C<make> or C<test> are run unconditionally. An
7345
7346   install <distribution_file>
7347
7348 also is run unconditionally. But for
7349
7350   install <module>
7351
7352 CPAN checks if an install is actually needed for it and prints
7353 I<module up to date> in the case that the distribution file containing
7354 the module doesn't need to be updated.
7355
7356 CPAN also keeps track of what it has done within the current session
7357 and doesn't try to build a package a second time regardless if it
7358 succeeded or not. The C<force> pragma may precede another command
7359 (currently: C<make>, C<test>, or C<install>) and executes the
7360 command from scratch and tries to continue in case of some errors.
7361
7362 Example:
7363
7364     cpan> install OpenGL
7365     OpenGL is up to date.
7366     cpan> force install OpenGL
7367     Running make
7368     OpenGL-0.4/
7369     OpenGL-0.4/COPYRIGHT
7370     [...]
7371
7372 The C<notest> pragma may be set to skip the test part in the build
7373 process.
7374
7375 Example:
7376
7377     cpan> notest install Tk
7378
7379 A C<clean> command results in a
7380
7381   make clean
7382
7383 being executed within the distribution file's working directory.
7384
7385 =item get, readme, perldoc, look module or distribution
7386
7387 C<get> downloads a distribution file without further action. C<readme>
7388 displays the README file of the associated distribution. C<Look> gets
7389 and untars (if not yet done) the distribution file, changes to the
7390 appropriate directory and opens a subshell process in that directory.
7391 C<perldoc> displays the pod documentation of the module in html or
7392 plain text format.
7393
7394 =item ls author
7395
7396 =item ls globbing_expression
7397
7398 The first form lists all distribution files in and below an author's
7399 CPAN directory as they are stored in the CHECKUMS files distributed on
7400 CPAN. The listing goes recursive into all subdirectories.
7401
7402 The second form allows to limit or expand the output with shell
7403 globbing as in the following examples:
7404
7405           ls JV/make*
7406           ls GSAR/*make*
7407           ls */*make*
7408
7409 The last example is very slow and outputs extra progress indicators
7410 that break the alignment of the result.
7411
7412 Note that globbing only lists directories explicitly asked for, for
7413 example FOO/* will not list FOO/bar/Acme-Sthg-n.nn.tar.gz. This may be
7414 regarded as a bug and may be changed in future versions.
7415
7416 =item failed
7417
7418 The C<failed> command reports all distributions that failed on one of
7419 C<make>, C<test> or C<install> for some reason in the currently
7420 running shell session.
7421
7422 =item Lockfile
7423
7424 Interactive sessions maintain a lockfile, per default C<~/.cpan/.lock>
7425 (but the directory can be configured via the C<cpan_home> config
7426 variable). The shell is a bit picky if you try to start another CPAN
7427 session. It dies immediately if there is a lockfile and the lock seems
7428 to belong to a running process. In case you want to run a second shell
7429 session, it is probably safest to maintain another directory, say
7430 C<~/.cpan-for-X/> and a C<~/.cpan-for-X/CPAN/MyConfig.pm> that
7431 contains the configuration options. Then you can start the second
7432 shell with
7433
7434   perl -I ~/.cpan-for-X -MCPAN::MyConfig -MCPAN -e shell
7435
7436 =item Signals
7437
7438 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
7439 in the cpan-shell it is intended that you can press C<^C> anytime and
7440 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
7441 to clean up and leave the shell loop. You can emulate the effect of a
7442 SIGTERM by sending two consecutive SIGINTs, which usually means by
7443 pressing C<^C> twice.
7444
7445 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
7446 SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl
7447 Build.PL> subprocess.
7448
7449 =back
7450
7451 =head2 CPAN::Shell
7452
7453 The commands that are available in the shell interface are methods in
7454 the package CPAN::Shell. If you enter the shell command, all your
7455 input is split by the Text::ParseWords::shellwords() routine which
7456 acts like most shells do. The first word is being interpreted as the
7457 method to be called and the rest of the words are treated as arguments
7458 to this method. Continuation lines are supported if a line ends with a
7459 literal backslash.
7460
7461 =head2 autobundle
7462
7463 C<autobundle> writes a bundle file into the
7464 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
7465 a list of all modules that are both available from CPAN and currently
7466 installed within @INC. The name of the bundle file is based on the
7467 current date and a counter.
7468
7469 =head2 recompile
7470
7471 recompile() is a very special command in that it takes no argument and
7472 runs the make/test/install cycle with brute force over all installed
7473 dynamically loadable extensions (aka XS modules) with 'force' in
7474 effect. The primary purpose of this command is to finish a network
7475 installation. Imagine, you have a common source tree for two different
7476 architectures. You decide to do a completely independent fresh
7477 installation. You start on one architecture with the help of a Bundle
7478 file produced earlier. CPAN installs the whole Bundle for you, but
7479 when you try to repeat the job on the second architecture, CPAN
7480 responds with a C<"Foo up to date"> message for all modules. So you
7481 invoke CPAN's recompile on the second architecture and you're done.
7482
7483 Another popular use for C<recompile> is to act as a rescue in case your
7484 perl breaks binary compatibility. If one of the modules that CPAN uses
7485 is in turn depending on binary compatibility (so you cannot run CPAN
7486 commands), then you should try the CPAN::Nox module for recovery.
7487
7488 =head2 upgrade
7489
7490 The C<upgrade> command first runs an C<r> command and then installs
7491 the newest versions of all modules that were listed by that.
7492
7493 =head2 mkmyconfig
7494
7495 mkmyconfig() writes your own CPAN::MyConfig file into your ~/.cpan/
7496 directory so that you can save your own preferences instead of the
7497 system wide ones.
7498
7499 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
7500
7501 Although it may be considered internal, the class hierarchy does matter
7502 for both users and programmer. CPAN.pm deals with above mentioned four
7503 classes, and all those classes share a set of methods. A classical
7504 single polymorphism is in effect. A metaclass object registers all
7505 objects of all kinds and indexes them with a string. The strings
7506 referencing objects have a separated namespace (well, not completely
7507 separated):
7508
7509          Namespace                         Class
7510
7511    words containing a "/" (slash)      Distribution
7512     words starting with Bundle::          Bundle
7513           everything else            Module or Author
7514
7515 Modules know their associated Distribution objects. They always refer
7516 to the most recent official release. Developers may mark their releases
7517 as unstable development versions (by inserting an underbar into the
7518 module version number which will also be reflected in the distribution
7519 name when you run 'make dist'), so the really hottest and newest
7520 distribution is not always the default.  If a module Foo circulates
7521 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
7522 way to install version 1.23 by saying
7523
7524     install Foo
7525
7526 This would install the complete distribution file (say
7527 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
7528 like to install version 1.23_90, you need to know where the
7529 distribution file resides on CPAN relative to the authors/id/
7530 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
7531 so you would have to say
7532
7533     install BAR/Foo-1.23_90.tar.gz
7534
7535 The first example will be driven by an object of the class
7536 CPAN::Module, the second by an object of class CPAN::Distribution.
7537
7538 =head2 Programmer's interface
7539
7540 If you do not enter the shell, the available shell commands are both
7541 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
7542 functions in the calling package (C<install(...)>).
7543
7544 There's currently only one class that has a stable interface -
7545 CPAN::Shell. All commands that are available in the CPAN shell are
7546 methods of the class CPAN::Shell. Each of the commands that produce
7547 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
7548 the IDs of all modules within the list.
7549
7550 =over 2
7551
7552 =item expand($type,@things)
7553
7554 The IDs of all objects available within a program are strings that can
7555 be expanded to the corresponding real objects with the
7556 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
7557 list of CPAN::Module objects according to the C<@things> arguments
7558 given. In scalar context it only returns the first element of the
7559 list.
7560
7561 =item expandany(@things)
7562
7563 Like expand, but returns objects of the appropriate type, i.e.
7564 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
7565 CPAN::Distribution objects for distributions. Note: it does not expand
7566 to CPAN::Author objects.
7567
7568 =item Programming Examples
7569
7570 This enables the programmer to do operations that combine
7571 functionalities that are available in the shell.
7572
7573     # install everything that is outdated on my disk:
7574     perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
7575
7576     # install my favorite programs if necessary:
7577     for $mod (qw(Net::FTP Digest::SHA Data::Dumper)){
7578         my $obj = CPAN::Shell->expand('Module',$mod);
7579         $obj->install;
7580     }
7581
7582     # list all modules on my disk that have no VERSION number
7583     for $mod (CPAN::Shell->expand("Module","/./")){
7584         next unless $mod->inst_file;
7585         # MakeMaker convention for undefined $VERSION:
7586         next unless $mod->inst_version eq "undef";
7587         print "No VERSION in ", $mod->id, "\n";
7588     }
7589
7590     # find out which distribution on CPAN contains a module:
7591     print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
7592
7593 Or if you want to write a cronjob to watch The CPAN, you could list
7594 all modules that need updating. First a quick and dirty way:
7595
7596     perl -e 'use CPAN; CPAN::Shell->r;'
7597
7598 If you don't want to get any output in the case that all modules are
7599 up to date, you can parse the output of above command for the regular
7600 expression //modules are up to date// and decide to mail the output
7601 only if it doesn't match. Ick?
7602
7603 If you prefer to do it more in a programmer style in one single
7604 process, maybe something like this suits you better:
7605
7606   # list all modules on my disk that have newer versions on CPAN
7607   for $mod (CPAN::Shell->expand("Module","/./")){
7608     next unless $mod->inst_file;
7609     next if $mod->uptodate;
7610     printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
7611         $mod->id, $mod->inst_version, $mod->cpan_version;
7612   }
7613
7614 If that gives you too much output every day, you maybe only want to
7615 watch for three modules. You can write
7616
7617   for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
7618
7619 as the first line instead. Or you can combine some of the above
7620 tricks:
7621
7622   # watch only for a new mod_perl module
7623   $mod = CPAN::Shell->expand("Module","mod_perl");
7624   exit if $mod->uptodate;
7625   # new mod_perl arrived, let me know all update recommendations
7626   CPAN::Shell->r;
7627
7628 =back
7629
7630 =head2 Methods in the other Classes
7631
7632 The programming interface for the classes CPAN::Module,
7633 CPAN::Distribution, CPAN::Bundle, and CPAN::Author is still considered
7634 beta and partially even alpha. In the following paragraphs only those
7635 methods are documented that have proven useful over a longer time and
7636 thus are unlikely to change.
7637
7638 =over 4
7639
7640 =item CPAN::Author::as_glimpse()
7641
7642 Returns a one-line description of the author
7643
7644 =item CPAN::Author::as_string()
7645
7646 Returns a multi-line description of the author
7647
7648 =item CPAN::Author::email()
7649
7650 Returns the author's email address
7651
7652 =item CPAN::Author::fullname()
7653
7654 Returns the author's name
7655
7656 =item CPAN::Author::name()
7657
7658 An alias for fullname
7659
7660 =item CPAN::Bundle::as_glimpse()
7661
7662 Returns a one-line description of the bundle
7663
7664 =item CPAN::Bundle::as_string()
7665
7666 Returns a multi-line description of the bundle
7667
7668 =item CPAN::Bundle::clean()
7669
7670 Recursively runs the C<clean> method on all items contained in the bundle.
7671
7672 =item CPAN::Bundle::contains()
7673
7674 Returns a list of objects' IDs contained in a bundle. The associated
7675 objects may be bundles, modules or distributions.
7676
7677 =item CPAN::Bundle::force($method,@args)
7678
7679 Forces CPAN to perform a task that normally would have failed. Force
7680 takes as arguments a method name to be called and any number of
7681 additional arguments that should be passed to the called method. The
7682 internals of the object get the needed changes so that CPAN.pm does
7683 not refuse to take the action. The C<force> is passed recursively to
7684 all contained objects.
7685
7686 =item CPAN::Bundle::get()
7687
7688 Recursively runs the C<get> method on all items contained in the bundle
7689
7690 =item CPAN::Bundle::inst_file()
7691
7692 Returns the highest installed version of the bundle in either @INC or
7693 C<$CPAN::Config->{cpan_home}>. Note that this is different from
7694 CPAN::Module::inst_file.
7695
7696 =item CPAN::Bundle::inst_version()
7697
7698 Like CPAN::Bundle::inst_file, but returns the $VERSION
7699
7700 =item CPAN::Bundle::uptodate()
7701
7702 Returns 1 if the bundle itself and all its members are uptodate.
7703
7704 =item CPAN::Bundle::install()
7705
7706 Recursively runs the C<install> method on all items contained in the bundle
7707
7708 =item CPAN::Bundle::make()
7709
7710 Recursively runs the C<make> method on all items contained in the bundle
7711
7712 =item CPAN::Bundle::readme()
7713
7714 Recursively runs the C<readme> method on all items contained in the bundle
7715
7716 =item CPAN::Bundle::test()
7717
7718 Recursively runs the C<test> method on all items contained in the bundle
7719
7720 =item CPAN::Distribution::as_glimpse()
7721
7722 Returns a one-line description of the distribution
7723
7724 =item CPAN::Distribution::as_string()
7725
7726 Returns a multi-line description of the distribution
7727
7728 =item CPAN::Distribution::author
7729
7730 Returns the CPAN::Author object of the maintainer who uploaded this
7731 distribution
7732
7733 =item CPAN::Distribution::clean()
7734
7735 Changes to the directory where the distribution has been unpacked and
7736 runs C<make clean> there.
7737
7738 =item CPAN::Distribution::containsmods()
7739
7740 Returns a list of IDs of modules contained in a distribution file.
7741 Only works for distributions listed in the 02packages.details.txt.gz
7742 file. This typically means that only the most recent version of a
7743 distribution is covered.
7744
7745 =item CPAN::Distribution::cvs_import()
7746
7747 Changes to the directory where the distribution has been unpacked and
7748 runs something like
7749
7750     cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
7751
7752 there.
7753
7754 =item CPAN::Distribution::dir()
7755
7756 Returns the directory into which this distribution has been unpacked.
7757
7758 =item CPAN::Distribution::force($method,@args)
7759
7760 Forces CPAN to perform a task that normally would have failed. Force
7761 takes as arguments a method name to be called and any number of
7762 additional arguments that should be passed to the called method. The
7763 internals of the object get the needed changes so that CPAN.pm does
7764 not refuse to take the action.
7765
7766 =item CPAN::Distribution::get()
7767
7768 Downloads the distribution from CPAN and unpacks it. Does nothing if
7769 the distribution has already been downloaded and unpacked within the
7770 current session.
7771
7772 =item CPAN::Distribution::install()
7773
7774 Changes to the directory where the distribution has been unpacked and
7775 runs the external command C<make install> there. If C<make> has not
7776 yet been run, it will be run first. A C<make test> will be issued in
7777 any case and if this fails, the install will be canceled. The
7778 cancellation can be avoided by letting C<force> run the C<install> for
7779 you.
7780
7781 Note that install() gives no meaningful return value. See uptodate().
7782
7783 =item CPAN::Distribution::isa_perl()
7784
7785 Returns 1 if this distribution file seems to be a perl distribution.
7786 Normally this is derived from the file name only, but the index from
7787 CPAN can contain a hint to achieve a return value of true for other
7788 filenames too.
7789
7790 =item CPAN::Distribution::look()
7791
7792 Changes to the directory where the distribution has been unpacked and
7793 opens a subshell there. Exiting the subshell returns.
7794
7795 =item CPAN::Distribution::make()
7796
7797 First runs the C<get> method to make sure the distribution is
7798 downloaded and unpacked. Changes to the directory where the
7799 distribution has been unpacked and runs the external commands C<perl
7800 Makefile.PL> or C<perl Build.PL> and C<make> there.
7801
7802 =item CPAN::Distribution::perldoc()
7803
7804 Downloads the pod documentation of the file associated with a
7805 distribution (in html format) and runs it through the external
7806 command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
7807 isn't available, it converts it to plain text with external
7808 command html2text and runs it through the pager specified
7809 in C<$CPAN::Config->{pager}>
7810
7811 =item CPAN::Distribution::prereq_pm()
7812
7813 Returns the hash reference that has been announced by a distribution
7814 as the merge of the C<requires> element and the C<build_requires>
7815 element of the META.yml or the C<PREREQ_PM> hash in the
7816 C<Makefile.PL>. Note: works only after an attempt has been made to
7817 C<make> the distribution. Returns undef otherwise.
7818
7819 =item CPAN::Distribution::readme()
7820
7821 Downloads the README file associated with a distribution and runs it
7822 through the pager specified in C<$CPAN::Config->{pager}>.
7823
7824 =item CPAN::Distribution::read_yaml()
7825
7826 Returns the content of the META.yml of this distro as a hashref. Note:
7827 works only after an attempt has been made to C<make> the distribution.
7828 Returns undef otherwise.
7829
7830 =item CPAN::Distribution::test()
7831
7832 Changes to the directory where the distribution has been unpacked and
7833 runs C<make test> there.
7834
7835 =item CPAN::Distribution::uptodate()
7836
7837 Returns 1 if all the modules contained in the distribution are
7838 uptodate. Relies on containsmods.
7839
7840 =item CPAN::Index::force_reload()
7841
7842 Forces a reload of all indices.
7843
7844 =item CPAN::Index::reload()
7845
7846 Reloads all indices if they have not been read for more than
7847 C<$CPAN::Config->{index_expire}> days.
7848
7849 =item CPAN::InfoObj::dump()
7850
7851 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
7852 inherit this method. It prints the data structure associated with an
7853 object. Useful for debugging. Note: the data structure is considered
7854 internal and thus subject to change without notice.
7855
7856 =item CPAN::Module::as_glimpse()
7857
7858 Returns a one-line description of the module in four columns: The
7859 first column contains the word C<Module>, the second column consists
7860 of one character: an equals sign if this module is already installed
7861 and uptodate, a less-than sign if this module is installed but can be
7862 upgraded, and a space if the module is not installed. The third column
7863 is the name of the module and the fourth column gives maintainer or
7864 distribution information.
7865
7866 =item CPAN::Module::as_string()
7867
7868 Returns a multi-line description of the module
7869
7870 =item CPAN::Module::clean()
7871
7872 Runs a clean on the distribution associated with this module.
7873
7874 =item CPAN::Module::cpan_file()
7875
7876 Returns the filename on CPAN that is associated with the module.
7877
7878 =item CPAN::Module::cpan_version()
7879
7880 Returns the latest version of this module available on CPAN.
7881
7882 =item CPAN::Module::cvs_import()
7883
7884 Runs a cvs_import on the distribution associated with this module.
7885
7886 =item CPAN::Module::description()
7887
7888 Returns a 44 character description of this module. Only available for
7889 modules listed in The Module List (CPAN/modules/00modlist.long.html
7890 or 00modlist.long.txt.gz)
7891
7892 =item CPAN::Module::distribution()
7893
7894 Returns the CPAN::Distribution object that contains the current
7895 version of this module.
7896
7897 =item CPAN::Module::dslip_status()
7898
7899 Returns a hash reference. The keys of the hash are the letters C<D>,
7900 C<S>, C<L>, C<I>, and <P>, for development status, support level,
7901 language, interface and public licence respectively. The data for the
7902 DSLIP status are collected by pause.perl.org when authors register
7903 their namespaces. The values of the 5 hash elements are one-character
7904 words whose meaning is described in the table below. There are also 5
7905 hash elements C<DV>, C<SV>, C<LV>, C<IV>, and <PV> that carry a more
7906 verbose value of the 5 status variables.
7907
7908 Where the 'DSLIP' characters have the following meanings:
7909
7910   D - Development Stage  (Note: *NO IMPLIED TIMESCALES*):
7911     i   - Idea, listed to gain consensus or as a placeholder
7912     c   - under construction but pre-alpha (not yet released)
7913     a/b - Alpha/Beta testing
7914     R   - Released
7915     M   - Mature (no rigorous definition)
7916     S   - Standard, supplied with Perl 5
7917
7918   S - Support Level:
7919     m   - Mailing-list
7920     d   - Developer
7921     u   - Usenet newsgroup comp.lang.perl.modules
7922     n   - None known, try comp.lang.perl.modules
7923     a   - abandoned; volunteers welcome to take over maintainance
7924
7925   L - Language Used:
7926     p   - Perl-only, no compiler needed, should be platform independent
7927     c   - C and perl, a C compiler will be needed
7928     h   - Hybrid, written in perl with optional C code, no compiler needed
7929     +   - C++ and perl, a C++ compiler will be needed
7930     o   - perl and another language other than C or C++
7931
7932   I - Interface Style
7933     f   - plain Functions, no references used
7934     h   - hybrid, object and function interfaces available
7935     n   - no interface at all (huh?)
7936     r   - some use of unblessed References or ties
7937     O   - Object oriented using blessed references and/or inheritance
7938
7939   P - Public License
7940     p   - Standard-Perl: user may choose between GPL and Artistic
7941     g   - GPL: GNU General Public License
7942     l   - LGPL: "GNU Lesser General Public License" (previously known as
7943           "GNU Library General Public License")
7944     b   - BSD: The BSD License
7945     a   - Artistic license alone
7946     o   - open source: appoved by www.opensource.org
7947     d   - allows distribution without restrictions
7948     r   - restricted distribtion
7949     n   - no license at all
7950
7951 =item CPAN::Module::force($method,@args)
7952
7953 Forces CPAN to perform a task that normally would have failed. Force
7954 takes as arguments a method name to be called and any number of
7955 additional arguments that should be passed to the called method. The
7956 internals of the object get the needed changes so that CPAN.pm does
7957 not refuse to take the action.
7958
7959 =item CPAN::Module::get()
7960
7961 Runs a get on the distribution associated with this module.
7962
7963 =item CPAN::Module::inst_file()
7964
7965 Returns the filename of the module found in @INC. The first file found
7966 is reported just like perl itself stops searching @INC when it finds a
7967 module.
7968
7969 =item CPAN::Module::inst_version()
7970
7971 Returns the version number of the module in readable format.
7972
7973 =item CPAN::Module::install()
7974
7975 Runs an C<install> on the distribution associated with this module.
7976
7977 =item CPAN::Module::look()
7978
7979 Changes to the directory where the distribution associated with this
7980 module has been unpacked and opens a subshell there. Exiting the
7981 subshell returns.
7982
7983 =item CPAN::Module::make()
7984
7985 Runs a C<make> on the distribution associated with this module.
7986
7987 =item CPAN::Module::manpage_headline()
7988
7989 If module is installed, peeks into the module's manpage, reads the
7990 headline and returns it. Moreover, if the module has been downloaded
7991 within this session, does the equivalent on the downloaded module even
7992 if it is not installed.
7993
7994 =item CPAN::Module::perldoc()
7995
7996 Runs a C<perldoc> on this module.
7997
7998 =item CPAN::Module::readme()
7999
8000 Runs a C<readme> on the distribution associated with this module.
8001
8002 =item CPAN::Module::test()
8003
8004 Runs a C<test> on the distribution associated with this module.
8005
8006 =item CPAN::Module::uptodate()
8007
8008 Returns 1 if the module is installed and up-to-date.
8009
8010 =item CPAN::Module::userid()
8011
8012 Returns the author's ID of the module.
8013
8014 =back
8015
8016 =head2 Cache Manager
8017
8018 Currently the cache manager only keeps track of the build directory
8019 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
8020 deletes complete directories below C<build_dir> as soon as the size of
8021 all directories there gets bigger than $CPAN::Config->{build_cache}
8022 (in MB). The contents of this cache may be used for later
8023 re-installations that you intend to do manually, but will never be
8024 trusted by CPAN itself. This is due to the fact that the user might
8025 use these directories for building modules on different architectures.
8026
8027 There is another directory ($CPAN::Config->{keep_source_where}) where
8028 the original distribution files are kept. This directory is not
8029 covered by the cache manager and must be controlled by the user. If
8030 you choose to have the same directory as build_dir and as
8031 keep_source_where directory, then your sources will be deleted with
8032 the same fifo mechanism.
8033
8034 =head2 Bundles
8035
8036 A bundle is just a perl module in the namespace Bundle:: that does not
8037 define any functions or methods. It usually only contains documentation.
8038
8039 It starts like a perl module with a package declaration and a $VERSION
8040 variable. After that the pod section looks like any other pod with the
8041 only difference being that I<one special pod section> exists starting with
8042 (verbatim):
8043
8044         =head1 CONTENTS
8045
8046 In this pod section each line obeys the format
8047
8048         Module_Name [Version_String] [- optional text]
8049
8050 The only required part is the first field, the name of a module
8051 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
8052 of the line is optional. The comment part is delimited by a dash just
8053 as in the man page header.
8054
8055 The distribution of a bundle should follow the same convention as
8056 other distributions.
8057
8058 Bundles are treated specially in the CPAN package. If you say 'install
8059 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
8060 the modules in the CONTENTS section of the pod. You can install your
8061 own Bundles locally by placing a conformant Bundle file somewhere into
8062 your @INC path. The autobundle() command which is available in the
8063 shell interface does that for you by including all currently installed
8064 modules in a snapshot bundle file.
8065
8066 =head2 Prerequisites
8067
8068 If you have a local mirror of CPAN and can access all files with
8069 "file:" URLs, then you only need a perl better than perl5.003 to run
8070 this module. Otherwise Net::FTP is strongly recommended. LWP may be
8071 required for non-UNIX systems or if your nearest CPAN site is
8072 associated with a URL that is not C<ftp:>.
8073
8074 If you have neither Net::FTP nor LWP, there is a fallback mechanism
8075 implemented for an external ftp command or for an external lynx
8076 command.
8077
8078 =head2 Finding packages and VERSION
8079
8080 This module presumes that all packages on CPAN
8081
8082 =over 2
8083
8084 =item *
8085
8086 declare their $VERSION variable in an easy to parse manner. This
8087 prerequisite can hardly be relaxed because it consumes far too much
8088 memory to load all packages into the running program just to determine
8089 the $VERSION variable. Currently all programs that are dealing with
8090 version use something like this
8091
8092     perl -MExtUtils::MakeMaker -le \
8093         'print MM->parse_version(shift)' filename
8094
8095 If you are author of a package and wonder if your $VERSION can be
8096 parsed, please try the above method.
8097
8098 =item *
8099
8100 come as compressed or gzipped tarfiles or as zip files and contain a
8101 C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
8102 without much enthusiasm).
8103
8104 =back
8105
8106 =head2 Debugging
8107
8108 The debugging of this module is a bit complex, because we have
8109 interferences of the software producing the indices on CPAN, of the
8110 mirroring process on CPAN, of packaging, of configuration, of
8111 synchronicity, and of bugs within CPAN.pm.
8112
8113 For code debugging in interactive mode you can try "o debug" which
8114 will list options for debugging the various parts of the code. You
8115 should know that "o debug" has built-in completion support.
8116
8117 For data debugging there is the C<dump> command which takes the same
8118 arguments as make/test/install and outputs the object's Data::Dumper
8119 dump.
8120
8121 =head2 Floppy, Zip, Offline Mode
8122
8123 CPAN.pm works nicely without network too. If you maintain machines
8124 that are not networked at all, you should consider working with file:
8125 URLs. Of course, you have to collect your modules somewhere first. So
8126 you might use CPAN.pm to put together all you need on a networked
8127 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
8128 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
8129 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
8130 with this floppy. See also below the paragraph about CD-ROM support.
8131
8132 =head1 CONFIGURATION
8133
8134 When the CPAN module is used for the first time, a configuration
8135 dialog tries to determine a couple of site specific options. The
8136 result of the dialog is stored in a hash reference C< $CPAN::Config >
8137 in a file CPAN/Config.pm.
8138
8139 The default values defined in the CPAN/Config.pm file can be
8140 overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
8141 best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
8142 added to the search path of the CPAN module before the use() or
8143 require() statements.
8144
8145 The configuration dialog can be started any time later again by
8146 issuing the command C< o conf init > in the CPAN shell. A subset of
8147 the configuration dialog can be run by issuing C<o conf init WORD>
8148 where WORD is any valid config variable or a regular expression.
8149
8150 Currently the following keys in the hash reference $CPAN::Config are
8151 defined:
8152
8153   build_cache        size of cache for directories to build modules
8154   build_dir          locally accessible directory to build modules
8155   cache_metadata     use serializer to cache metadata
8156   commands_quote     prefered character to use for quoting external
8157                      commands when running them. Defaults to double
8158                      quote on Windows, single tick everywhere else;
8159                      can be set to space to disable quoting
8160   check_sigs         if signatures should be verified
8161   cpan_home          local directory reserved for this package
8162   dontload_list      arrayref: modules in the list will not be
8163                      loaded by the CPAN::has_inst() routine
8164   getcwd             see below
8165   gzip               location of external program gzip
8166   histfile           file to maintain history between sessions
8167   histsize           maximum number of lines to keep in histfile
8168   inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
8169                      after this many seconds inactivity. Set to 0 to
8170                      never break.
8171   index_expire       after this many days refetch index files
8172   inhibit_startup_message
8173                      if true, does not print the startup message
8174   keep_source_where  directory in which to keep the source (if we do)
8175   make               location of external make program
8176   make_arg           arguments that should always be passed to 'make'
8177   make_install_make_command
8178                      the make command for running 'make install', for
8179                      example 'sudo make'
8180   make_install_arg   same as make_arg for 'make install'
8181   makepl_arg         arguments passed to 'perl Makefile.PL'
8182   mbuild_arg         arguments passed to './Build'
8183   mbuild_install_arg arguments passed to './Build install'
8184   mbuild_install_build_command
8185                      command to use instead of './Build' when we are
8186                      in the install stage, for example 'sudo ./Build'
8187   mbuildpl_arg       arguments passed to 'perl Build.PL'
8188   pager              location of external program more (or any pager)
8189   prefer_installer   legal values are MB and EUMM: if a module comes
8190                      with both a Makefile.PL and a Build.PL, use the
8191                      former (EUMM) or the latter (MB); if the module
8192                      comes with only one of the two, that one will be
8193                      used in any case
8194   prerequisites_policy
8195                      what to do if you are missing module prerequisites
8196                      ('follow' automatically, 'ask' me, or 'ignore')
8197   proxy_user         username for accessing an authenticating proxy
8198   proxy_pass         password for accessing an authenticating proxy
8199   scan_cache         controls scanning of cache ('atstart' or 'never')
8200   tar                location of external program tar
8201   term_is_latin      if true internal UTF-8 is translated to ISO-8859-1
8202                      (and nonsense for characters outside latin range)
8203   test_report        email test reports (if CPAN::Reporter is installed)
8204   unzip              location of external program unzip
8205   urllist            arrayref to nearby CPAN sites (or equivalent locations)
8206   wait_list          arrayref to a wait server to try (See CPAN::WAIT)
8207   ftp_passive        if set, the envariable FTP_PASSIVE is set for downloads
8208   ftp_proxy,      }  the three usual variables for configuring
8209     http_proxy,   }  proxy requests. Both as CPAN::Config variables
8210     no_proxy      }  and as environment variables configurable.
8211
8212 You can set and query each of these options interactively in the cpan
8213 shell with the command set defined within the C<o conf> command:
8214
8215 =over 2
8216
8217 =item C<o conf E<lt>scalar optionE<gt>>
8218
8219 prints the current value of the I<scalar option>
8220
8221 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
8222
8223 Sets the value of the I<scalar option> to I<value>
8224
8225 =item C<o conf E<lt>list optionE<gt>>
8226
8227 prints the current value of the I<list option> in MakeMaker's
8228 neatvalue format.
8229
8230 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
8231
8232 shifts or pops the array in the I<list option> variable
8233
8234 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
8235
8236 works like the corresponding perl commands.
8237
8238 =back
8239
8240 =head2 Note on config variable getcwd
8241
8242 CPAN.pm changes the current working directory often and needs to
8243 determine its own current working directory. Per default it uses
8244 Cwd::cwd but if this doesn't work on your system for some reason,
8245 alternatives can be configured according to the following table:
8246
8247     cwd         Cwd::cwd
8248     getcwd      Cwd::getcwd
8249     fastcwd     Cwd::fastcwd
8250     backtickcwd external command cwd
8251
8252 =head2 Note on urllist parameter's format
8253
8254 urllist parameters are URLs according to RFC 1738. We do a little
8255 guessing if your URL is not compliant, but if you have problems with
8256 file URLs, please try the correct format. Either:
8257
8258     file://localhost/whatever/ftp/pub/CPAN/
8259
8260 or
8261
8262     file:///home/ftp/pub/CPAN/
8263
8264 =head2 urllist parameter has CD-ROM support
8265
8266 The C<urllist> parameter of the configuration table contains a list of
8267 URLs that are to be used for downloading. If the list contains any
8268 C<file> URLs, CPAN always tries to get files from there first. This
8269 feature is disabled for index files. So the recommendation for the
8270 owner of a CD-ROM with CPAN contents is: include your local, possibly
8271 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
8272
8273   o conf urllist push file://localhost/CDROM/CPAN
8274
8275 CPAN.pm will then fetch the index files from one of the CPAN sites
8276 that come at the beginning of urllist. It will later check for each
8277 module if there is a local copy of the most recent version.
8278
8279 Another peculiarity of urllist is that the site that we could
8280 successfully fetch the last file from automatically gets a preference
8281 token and is tried as the first site for the next request. So if you
8282 add a new site at runtime it may happen that the previously preferred
8283 site will be tried another time. This means that if you want to disallow
8284 a site for the next transfer, it must be explicitly removed from
8285 urllist.
8286
8287 =head1 SECURITY
8288
8289 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
8290 install foreign, unmasked, unsigned code on your machine. We compare
8291 to a checksum that comes from the net just as the distribution file
8292 itself. But we try to make it easy to add security on demand:
8293
8294 =head2 Cryptographically signed modules
8295
8296 Since release 1.77 CPAN.pm has been able to verify cryptographically
8297 signed module distributions using Module::Signature.  The CPAN modules
8298 can be signed by their authors, thus giving more security.  The simple
8299 unsigned MD5 checksums that were used before by CPAN protect mainly
8300 against accidental file corruption.
8301
8302 You will need to have Module::Signature installed, which in turn
8303 requires that you have at least one of Crypt::OpenPGP module or the
8304 command-line F<gpg> tool installed.
8305
8306 You will also need to be able to connect over the Internet to the public
8307 keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
8308
8309 The configuration parameter check_sigs is there to turn signature
8310 checking on or off.
8311
8312 =head1 EXPORT
8313
8314 Most functions in package CPAN are exported per default. The reason
8315 for this is that the primary use is intended for the cpan shell or for
8316 one-liners.
8317
8318 =head1 ENVIRONMENT
8319
8320 When the CPAN shell enters a subshell via the look command, it sets
8321 the environment CPAN_SHELL_LEVEL to 1 or increments it if it is
8322 already set.
8323
8324 When the config variable ftp_passive is set, all downloads will be run
8325 with the environment variable FTP_PASSIVE set to this value. This is
8326 in general a good idea as it influences both Net::FTP and LWP based
8327 connections. The same effect can be achieved by starting the cpan
8328 shell with this environment variable set. For Net::FTP alone, one can
8329 also always set passive mode by running libnetcfg.
8330
8331 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
8332
8333 Populating a freshly installed perl with my favorite modules is pretty
8334 easy if you maintain a private bundle definition file. To get a useful
8335 blueprint of a bundle definition file, the command autobundle can be used
8336 on the CPAN shell command line. This command writes a bundle definition
8337 file for all modules that are installed for the currently running perl
8338 interpreter. It's recommended to run this command only once and from then
8339 on maintain the file manually under a private name, say
8340 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
8341
8342     cpan> install Bundle::my_bundle
8343
8344 then answer a few questions and then go out for a coffee.
8345
8346 Maintaining a bundle definition file means keeping track of two
8347 things: dependencies and interactivity. CPAN.pm sometimes fails on
8348 calculating dependencies because not all modules define all MakeMaker
8349 attributes correctly, so a bundle definition file should specify
8350 prerequisites as early as possible. On the other hand, it's a bit
8351 annoying that many distributions need some interactive configuring. So
8352 what I try to accomplish in my private bundle file is to have the
8353 packages that need to be configured early in the file and the gentle
8354 ones later, so I can go out after a few minutes and leave CPAN.pm
8355 untended.
8356
8357 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
8358
8359 Thanks to Graham Barr for contributing the following paragraphs about
8360 the interaction between perl, and various firewall configurations. For
8361 further information on firewalls, it is recommended to consult the
8362 documentation that comes with the ncftp program. If you are unable to
8363 go through the firewall with a simple Perl setup, it is very likely
8364 that you can configure ncftp so that it works for your firewall.
8365
8366 =head2 Three basic types of firewalls
8367
8368 Firewalls can be categorized into three basic types.
8369
8370 =over 4
8371
8372 =item http firewall
8373
8374 This is where the firewall machine runs a web server and to access the
8375 outside world you must do it via the web server. If you set environment
8376 variables like http_proxy or ftp_proxy to a values beginning with http://
8377 or in your web browser you have to set proxy information then you know
8378 you are running an http firewall.
8379
8380 To access servers outside these types of firewalls with perl (even for
8381 ftp) you will need to use LWP.
8382
8383 =item ftp firewall
8384
8385 This where the firewall machine runs an ftp server. This kind of
8386 firewall will only let you access ftp servers outside the firewall.
8387 This is usually done by connecting to the firewall with ftp, then
8388 entering a username like "user@outside.host.com"
8389
8390 To access servers outside these type of firewalls with perl you
8391 will need to use Net::FTP.
8392
8393 =item One way visibility
8394
8395 I say one way visibility as these firewalls try to make themselves look
8396 invisible to the users inside the firewall. An FTP data connection is
8397 normally created by sending the remote server your IP address and then
8398 listening for the connection. But the remote server will not be able to
8399 connect to you because of the firewall. So for these types of firewall
8400 FTP connections need to be done in a passive mode.
8401
8402 There are two that I can think off.
8403
8404 =over 4
8405
8406 =item SOCKS
8407
8408 If you are using a SOCKS firewall you will need to compile perl and link
8409 it with the SOCKS library, this is what is normally called a 'socksified'
8410 perl. With this executable you will be able to connect to servers outside
8411 the firewall as if it is not there.
8412
8413 =item IP Masquerade
8414
8415 This is the firewall implemented in the Linux kernel, it allows you to
8416 hide a complete network behind one IP address. With this firewall no
8417 special compiling is needed as you can access hosts directly.
8418
8419 For accessing ftp servers behind such firewalls you usually need to
8420 set the environment variable C<FTP_PASSIVE> or the config variable
8421 ftp_passive to a true value.
8422
8423 =back
8424
8425 =back
8426
8427 =head2 Configuring lynx or ncftp for going through a firewall
8428
8429 If you can go through your firewall with e.g. lynx, presumably with a
8430 command such as
8431
8432     /usr/local/bin/lynx -pscott:tiger
8433
8434 then you would configure CPAN.pm with the command
8435
8436     o conf lynx "/usr/local/bin/lynx -pscott:tiger"
8437
8438 That's all. Similarly for ncftp or ftp, you would configure something
8439 like
8440
8441     o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
8442
8443 Your mileage may vary...
8444
8445 =head1 FAQ
8446
8447 =over 4
8448
8449 =item 1)
8450
8451 I installed a new version of module X but CPAN keeps saying,
8452 I have the old version installed
8453
8454 Most probably you B<do> have the old version installed. This can
8455 happen if a module installs itself into a different directory in the
8456 @INC path than it was previously installed. This is not really a
8457 CPAN.pm problem, you would have the same problem when installing the
8458 module manually. The easiest way to prevent this behaviour is to add
8459 the argument C<UNINST=1> to the C<make install> call, and that is why
8460 many people add this argument permanently by configuring
8461
8462   o conf make_install_arg UNINST=1
8463
8464 =item 2)
8465
8466 So why is UNINST=1 not the default?
8467
8468 Because there are people who have their precise expectations about who
8469 may install where in the @INC path and who uses which @INC array. In
8470 fine tuned environments C<UNINST=1> can cause damage.
8471
8472 =item 3)
8473
8474 I want to clean up my mess, and install a new perl along with
8475 all modules I have. How do I go about it?
8476
8477 Run the autobundle command for your old perl and optionally rename the
8478 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
8479 with the Configure option prefix, e.g.
8480
8481     ./Configure -Dprefix=/usr/local/perl-5.6.78.9
8482
8483 Install the bundle file you produced in the first step with something like
8484
8485     cpan> install Bundle::mybundle
8486
8487 and you're done.
8488
8489 =item 4)
8490
8491 When I install bundles or multiple modules with one command
8492 there is too much output to keep track of.
8493
8494 You may want to configure something like
8495
8496   o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
8497   o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
8498
8499 so that STDOUT is captured in a file for later inspection.
8500
8501
8502 =item 5)
8503
8504 I am not root, how can I install a module in a personal directory?
8505
8506 First of all, you will want to use your own configuration, not the one
8507 that your root user installed. If you do not have permission to write
8508 in the cpan directory that root has configured, you will be asked if
8509 you want to create your own config. Answering "yes" will bring you into
8510 CPAN's configuration stage, using the system config for all defaults except
8511 things that have to do with CPAN's work directory, saving your choices to
8512 your MyConfig.pm file.
8513
8514 You can also manually initiate this process with the following command:
8515
8516     % perl -MCPAN -e 'mkmyconfig'
8517
8518 or by running
8519
8520     mkmyconfig
8521
8522 from the CPAN shell.
8523
8524 You will most probably also want to configure something like this:
8525
8526   o conf makepl_arg "LIB=~/myperl/lib \
8527                     INSTALLMAN1DIR=~/myperl/man/man1 \
8528                     INSTALLMAN3DIR=~/myperl/man/man3"
8529
8530 You can make this setting permanent like all C<o conf> settings with
8531 C<o conf commit>.
8532
8533 You will have to add ~/myperl/man to the MANPATH environment variable
8534 and also tell your perl programs to look into ~/myperl/lib, e.g. by
8535 including
8536
8537   use lib "$ENV{HOME}/myperl/lib";
8538
8539 or setting the PERL5LIB environment variable.
8540
8541 While we're speaking about $ENV{HOME}, it might be worth mentioning,
8542 that for Windows we use the File::HomeDir module that provides an
8543 equivalent to the concept of the home directory on Unix.
8544
8545 Another thing you should bear in mind is that the UNINST parameter can
8546 be dnagerous when you are installing into a private area because you
8547 might accidentally remove modules that other people depend on that are
8548 not using the private area.
8549
8550 =item 6)
8551
8552 How to get a package, unwrap it, and make a change before building it?
8553
8554 Have a look at the C<look> (!) command.
8555
8556 =item 7)
8557
8558 I installed a Bundle and had a couple of fails. When I
8559 retried, everything resolved nicely. Can this be fixed to work
8560 on first try?
8561
8562 The reason for this is that CPAN does not know the dependencies of all
8563 modules when it starts out. To decide about the additional items to
8564 install, it just uses data found in the META.yml file or the generated
8565 Makefile. An undetected missing piece breaks the process. But it may
8566 well be that your Bundle installs some prerequisite later than some
8567 depending item and thus your second try is able to resolve everything.
8568 Please note, CPAN.pm does not know the dependency tree in advance and
8569 cannot sort the queue of things to install in a topologically correct
8570 order. It resolves perfectly well IF all modules declare the
8571 prerequisites correctly with the PREREQ_PM attribute to MakeMaker or
8572 the C<requires> stanza of Module::Build. For bundles which fail and
8573 you need to install often, it is recommended to sort the Bundle
8574 definition file manually.
8575
8576 =item 8)
8577
8578 In our intranet we have many modules for internal use. How
8579 can I integrate these modules with CPAN.pm but without uploading
8580 the modules to CPAN?
8581
8582 Have a look at the CPAN::Site module.
8583
8584 =item 9)
8585
8586 When I run CPAN's shell, I get an error message about things in my
8587 /etc/inputrc (or ~/.inputrc) file.
8588
8589 These are readline issues and can only be fixed by studying readline
8590 configuration on your architecture and adjusting the referenced file
8591 accordingly. Please make a backup of the /etc/inputrc or ~/.inputrc
8592 and edit them. Quite often harmless changes like uppercasing or
8593 lowercasing some arguments solves the problem.
8594
8595 =item 10)
8596
8597 Some authors have strange characters in their names.
8598
8599 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
8600 expecting ISO-8859-1 charset, a converter can be activated by setting
8601 term_is_latin to a true value in your config file. One way of doing so
8602 would be
8603
8604     cpan> o conf term_is_latin 1
8605
8606 If other charset support is needed, please file a bugreport against
8607 CPAN.pm at rt.cpan.org and describe your needs. Maybe we can extend
8608 the support or maybe UTF-8 terminals become widely available.
8609
8610 =item 11)
8611
8612 When an install fails for some reason and then I correct the error
8613 condition and retry, CPAN.pm refuses to install the module, saying
8614 C<Already tried without success>.
8615
8616 Use the force pragma like so
8617
8618   force install Foo::Bar
8619
8620 This does a bit more than really needed because it untars the
8621 distribution again and runs make and test and only then install.
8622
8623 Or, if you find this is too fast and you would prefer to do smaller
8624 steps, say
8625
8626   force get Foo::Bar
8627
8628 first and then continue as always. C<Force get> I<forgets> previous
8629 error conditions.
8630
8631 Or you can use
8632
8633   look Foo::Bar
8634
8635 and then 'make install' directly in the subshell.
8636
8637 Or you leave the CPAN shell and start it again.
8638
8639 For the really curious, by accessing internals directly, you I<could>
8640
8641   !delete CPAN::Shell->expandany("Foo::Bar")->distribution->{install}
8642
8643 but this is neither guaranteed to work in the future nor is it a
8644 decent command.
8645
8646 =item 12)
8647
8648 How do I install a "DEVELOPER RELEASE" of a module?
8649
8650 By default, CPAN will install the latest non-developer release of a
8651 module. If you want to install a dev release, you have to specify the
8652 partial path starting with the author id to the tarball you wish to
8653 install, like so:
8654
8655     cpan> install KWILLIAMS/Module-Build-0.27_07.tar.gz
8656
8657 Note that you can use the C<ls> command to get this path listed.
8658
8659 =item 13)
8660
8661 How do I install a module and all its dependencies from the commandline,
8662 without being prompted for anything, despite my CPAN configuration
8663 (or lack thereof)?
8664
8665 CPAN uses ExtUtils::MakeMaker's prompt() function to ask its questions, so
8666 if you set the PERL_MM_USE_DEFAULT environment variable, you shouldn't be
8667 asked any questions at all (assuming the modules you are installing are
8668 nice about obeying that variable as well):
8669
8670     % PERL_MM_USE_DEFAULT=1 perl -MCPAN -e 'install My::Module'
8671
8672 =item 14)
8673
8674 How do I create a Module::Build based Build.PL derived from an
8675 ExtUtils::MakeMaker focused Makefile.PL?
8676
8677 http://search.cpan.org/search?query=Module::Build::Convert
8678
8679 http://accognoscere.org/papers/perl-module-build-convert/module-build-convert.html
8680
8681
8682 =back
8683
8684 =head1 BUGS
8685
8686 Please report bugs via http://rt.cpan.org/
8687
8688 Before submitting a bug, please make sure that the traditional method
8689 of building a Perl module package from a shell by following the
8690 installation instructions of that package still works in your
8691 environment.
8692
8693 =head1 SECURITY ADVICE
8694
8695 This software enables you to upgrade software on your computer and so
8696 is inherently dangerous because the newly installed software may
8697 contain bugs and may alter the way your computer works or even make it
8698 unusable. Please consider backing up your data before every upgrade.
8699
8700 =head1 AUTHOR
8701
8702 Andreas Koenig C<< <andk@cpan.org> >>
8703
8704 =head1 TRANSLATIONS
8705
8706 Kawai,Takanori provides a Japanese translation of this manpage at
8707 http://member.nifty.ne.jp/hippo2000/perltips/CPAN.htm
8708
8709 =head1 SEE ALSO
8710
8711 cpan(1), CPAN::Nox(3pm), CPAN::Version(3pm)
8712
8713 =cut