lib/CPAN.pm

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