lib/CPAN.pm

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