lib/CPAN.pm

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