lib/CPAN.pm

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