lib/CPAN.pm

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