lib/CPAN.pm

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