lib/CPAN.pm

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