lib/CPAN.pm

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