lib/CPAN.pm

   1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
   2 package CPAN;
   3 $VERSION = '1.80_57';
   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/,
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 { shift->ro->{CPAN_COMMENT} }
3768
3769 sub undelay {
3770     my $self = shift;
3771     delete $self->{later};
3772 }
3773
3774 # CPAN::Distribution::normalize
3775 sub normalize {
3776     my($self,$s) = @_;
3777     $s = $self->id unless defined $s;
3778     if (
3779         $s =~ tr|/|| == 1
3780         or
3781         $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
3782        ) {
3783         return $s if $s =~ m:^N/A|^Contact Author: ;
3784         $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
3785             $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
3786         CPAN->debug("s[$s]") if $CPAN::DEBUG;
3787     }
3788     $s;
3789 }
3790
3791 # mark as dirty/clean
3792 #-> sub CPAN::Distribution::color_cmd_tmps ;
3793 sub color_cmd_tmps {
3794     my($self) = shift;
3795     my($depth) = shift || 0;
3796     my($color) = shift || 0;
3797     my($ancestors) = shift || [];
3798     # a distribution needs to recurse into its prereq_pms
3799
3800     return if exists $self->{incommandcolor}
3801         && $self->{incommandcolor}==$color;
3802     if ($depth>=100){
3803         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
3804     }
3805     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
3806     my $prereq_pm = $self->prereq_pm;
3807     if (defined $prereq_pm) {
3808         for my $pre (keys %$prereq_pm) {
3809             my $premo = CPAN::Shell->expand("Module",$pre);
3810             $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
3811         }
3812     }
3813     if ($color==0) {
3814         delete $self->{sponsored_mods};
3815         delete $self->{badtestcnt};
3816     }
3817     $self->{incommandcolor} = $color;
3818 }
3819
3820 #-> sub CPAN::Distribution::as_string ;
3821 sub as_string {
3822   my $self = shift;
3823   $self->containsmods;
3824   $self->upload_date;
3825   $self->SUPER::as_string(@_);
3826 }
3827
3828 #-> sub CPAN::Distribution::containsmods ;
3829 sub containsmods {
3830   my $self = shift;
3831   return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
3832   my $dist_id = $self->{ID};
3833   for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
3834     my $mod_file = $mod->cpan_file or next;
3835     my $mod_id = $mod->{ID} or next;
3836     # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
3837     # sleep 1;
3838     $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
3839   }
3840   keys %{$self->{CONTAINSMODS}};
3841 }
3842
3843 #-> sub CPAN::Distribution::upload_date ;
3844 sub upload_date {
3845   my $self = shift;
3846   return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
3847   my(@local_wanted) = split(/\//,$self->id);
3848   my $filename = pop @local_wanted;
3849   push @local_wanted, "CHECKSUMS";
3850   my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
3851   return unless $author;
3852   my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
3853   return unless @dl;
3854   my($dirent) = grep { $_->[2] eq $filename } @dl;
3855   # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
3856   return unless $dirent->[1];
3857   return $self->{UPLOAD_DATE} = $dirent->[1];
3858 }
3859
3860 #-> sub CPAN::Distribution::uptodate ;
3861 sub uptodate {
3862     my($self) = @_;
3863     my $c;
3864     foreach $c ($self->containsmods) {
3865         my $obj = CPAN::Shell->expandany($c);
3866         return 0 unless $obj->uptodate;
3867     }
3868     return 1;
3869 }
3870
3871 #-> sub CPAN::Distribution::called_for ;
3872 sub called_for {
3873     my($self,$id) = @_;
3874     $self->{CALLED_FOR} = $id if defined $id;
3875     return $self->{CALLED_FOR};
3876 }
3877
3878 #-> sub CPAN::Distribution::safe_chdir ;
3879 sub safe_chdir {
3880   my($self,$todir) = @_;
3881   # we die if we cannot chdir and we are debuggable
3882   Carp::confess("safe_chdir called without todir argument")
3883         unless defined $todir and length $todir;
3884   if (chdir $todir) {
3885     $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
3886         if $CPAN::DEBUG;
3887   } else {
3888     unless (-x $todir) {
3889       unless (chmod 0755, $todir) {
3890         my $cwd = CPAN::anycwd();
3891         $CPAN::Frontend->mywarn("I have neither the -x permission nor the permission ".
3892                                 "to change the permission; cannot chdir ".
3893                                 "to '$todir'\n");
3894         sleep 5;
3895         $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
3896                                qq{to todir[$todir]: $!});
3897       }
3898     }
3899     if (chdir $todir) {
3900       $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
3901           if $CPAN::DEBUG;
3902     } else {
3903       my $cwd = CPAN::anycwd();
3904       $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
3905                              qq{to todir[$todir] (a chmod has been issued): $!});
3906     }
3907   }
3908 }
3909
3910 #-> sub CPAN::Distribution::get ;
3911 sub get {
3912     my($self) = @_;
3913   EXCUSE: {
3914         my @e;
3915         exists $self->{'build_dir'} and push @e,
3916             "Is already unwrapped into directory $self->{'build_dir'}";
3917         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
3918     }
3919     my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
3920
3921     #
3922     # Get the file on local disk
3923     #
3924
3925     my($local_file);
3926     my($local_wanted) =
3927         File::Spec->catfile(
3928                             $CPAN::Config->{keep_source_where},
3929                             "authors",
3930                             "id",
3931                             split(/\//,$self->id)
3932                            );
3933
3934     $self->debug("Doing localize") if $CPAN::DEBUG;
3935     unless ($local_file =
3936             CPAN::FTP->localize("authors/id/$self->{ID}",
3937                                 $local_wanted)) {
3938         my $note = "";
3939         if ($CPAN::Index::DATE_OF_02) {
3940             $note = "Note: Current database in memory was generated ".
3941                 "on $CPAN::Index::DATE_OF_02\n";
3942         }
3943         $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
3944     }
3945     $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
3946     $self->{localfile} = $local_file;
3947     return if $CPAN::Signal;
3948
3949     #
3950     # Check integrity
3951     #
3952     if ($CPAN::META->has_inst("Digest::SHA")) {
3953         $self->debug("Digest::SHA is installed, verifying");
3954         $self->verifyCHECKSUM;
3955     } else {
3956         $self->debug("Digest::SHA is NOT installed");
3957     }
3958     return if $CPAN::Signal;
3959
3960     #
3961     # Create a clean room and go there
3962     #
3963     $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
3964     my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
3965     $self->safe_chdir($builddir);
3966     $self->debug("Removing tmp") if $CPAN::DEBUG;
3967     File::Path::rmtree("tmp");
3968     mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
3969     if ($CPAN::Signal){
3970         $self->safe_chdir($sub_wd);
3971         return;
3972     }
3973     $self->safe_chdir("tmp");
3974
3975     #
3976     # Unpack the goods
3977     #
3978     $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
3979     my $ct = CPAN::Tarzip->new($local_file);
3980     if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i){
3981         $self->{was_uncompressed}++ unless $ct->gtest();
3982         $self->untar_me($ct);
3983     } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
3984         $self->unzip_me($ct);
3985     } elsif ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/) {
3986         $self->{was_uncompressed}++ unless $ct->gtest();
3987         $self->debug("calling pm2dir for local_file[$local_file]") if $CPAN::DEBUG;
3988         $self->pm2dir_me($local_file);
3989     } else {
3990         $self->{archived} = "NO";
3991         $self->safe_chdir($sub_wd);
3992         return;
3993     }
3994
3995     # we are still in the tmp directory!
3996     # Let's check if the package has its own directory.
3997     my $dh = DirHandle->new(File::Spec->curdir)
3998         or Carp::croak("Couldn't opendir .: $!");
3999     my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
4000     $dh->close;
4001     my ($distdir,$packagedir);
4002     if (@readdir == 1 && -d $readdir[0]) {
4003         $distdir = $readdir[0];
4004         $packagedir = File::Spec->catdir($builddir,$distdir);
4005         $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
4006             if $CPAN::DEBUG;
4007         -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
4008                                                     "$packagedir\n");
4009         File::Path::rmtree($packagedir);
4010         File::Copy::move($distdir,$packagedir) or
4011             Carp::confess("Couldn't move $distdir to $packagedir: $!");
4012         $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
4013                              $distdir,
4014                              $packagedir,
4015                              -e $packagedir,
4016                              -d $packagedir,
4017                             )) if $CPAN::DEBUG;
4018     } else {
4019         my $userid = $self->cpan_userid;
4020         unless ($userid) {
4021             CPAN->debug("no userid? self[$self]");
4022             $userid = "anon";
4023         }
4024         my $pragmatic_dir = $userid . '000';
4025         $pragmatic_dir =~ s/\W_//g;
4026         $pragmatic_dir++ while -d "../$pragmatic_dir";
4027         $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
4028         $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
4029         File::Path::mkpath($packagedir);
4030         my($f);
4031         for $f (@readdir) { # is already without "." and ".."
4032             my $to = File::Spec->catdir($packagedir,$f);
4033             File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
4034         }
4035     }
4036     if ($CPAN::Signal){
4037         $self->safe_chdir($sub_wd);
4038         return;
4039     }
4040
4041     $self->{'build_dir'} = $packagedir;
4042     $self->safe_chdir($builddir);
4043     File::Path::rmtree("tmp");
4044
4045     $self->safe_chdir($packagedir);
4046     if ($CPAN::META->has_inst("Module::Signature")) {
4047         if (-f "SIGNATURE") {
4048             $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
4049             my $rv = Module::Signature::verify();
4050             if ($rv != Module::Signature::SIGNATURE_OK() and
4051                 $rv != Module::Signature::SIGNATURE_MISSING()) {
4052                 $CPAN::Frontend->myprint(
4053                                          qq{\nSignature invalid for }.
4054                                          qq{distribution file. }.
4055                                          qq{Please investigate.\n\n}.
4056                                          $self->as_string,
4057                                          $CPAN::META->instance(
4058                                                                'CPAN::Author',
4059                                                                $self->cpan_userid,
4060                                                               )->as_string
4061                                         );
4062
4063                 my $wrap = qq{I\'d recommend removing $self->{localfile}. Its signature
4064 is invalid. Maybe you have configured your 'urllist' with
4065 a bad URL. Please check this array with 'o conf urllist', and
4066 retry.};
4067                 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
4068             }
4069         } else {
4070             $CPAN::Frontend->myprint(qq{Package came without SIGNATURE\n\n});
4071         }
4072     } else {
4073         $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
4074     }
4075     $self->safe_chdir($builddir);
4076     return if $CPAN::Signal;
4077
4078
4079     my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
4080     my($mpl_exists) = -f $mpl;
4081     unless ($mpl_exists) {
4082         # NFS has been reported to have racing problems after the
4083         # renaming of a directory in some environments.
4084         # This trick helps.
4085         sleep 1;
4086         my $mpldh = DirHandle->new($packagedir)
4087             or Carp::croak("Couldn't opendir $packagedir: $!");
4088         $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
4089         $mpldh->close;
4090     }
4091     my $prefer_installer = "eumm"; # eumm|mb
4092     if (-f File::Spec->catfile($packagedir,"Build.PL")) {
4093         if ($mpl_exists) { # they *can* choose
4094             if ($CPAN::META->has_inst("Module::Build")) {
4095                 $prefer_installer = $CPAN::Config->{prefer_installer};
4096             }
4097         } else {
4098             $prefer_installer = "mb";
4099         }
4100     }
4101     if (lc($prefer_installer) eq "mb") {
4102         $self->{modulebuild} = "YES";
4103     } elsif (! $mpl_exists) {
4104         $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
4105                              $mpl,
4106                              CPAN::anycwd(),
4107                             )) if $CPAN::DEBUG;
4108         my($configure) = File::Spec->catfile($packagedir,"Configure");
4109         if (-f $configure) {
4110             # do we have anything to do?
4111             $self->{'configure'} = $configure;
4112         } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
4113             $CPAN::Frontend->myprint(qq{
4114 Package comes with a Makefile and without a Makefile.PL.
4115 We\'ll try to build it with that Makefile then.
4116 });
4117             $self->{writemakefile} = "YES";
4118             sleep 2;
4119         } else {
4120             my $cf = $self->called_for || "unknown";
4121             if ($cf =~ m|/|) {
4122                 $cf =~ s|.*/||;
4123                 $cf =~ s|\W.*||;
4124             }
4125             $cf =~ s|[/\\:]||g; # risk of filesystem damage
4126             $cf = "unknown" unless length($cf);
4127             $CPAN::Frontend->myprint(qq{Package seems to come without Makefile.PL.
4128   (The test -f "$mpl" returned false.)
4129   Writing one on our own (setting NAME to $cf)\a\n});
4130             $self->{had_no_makefile_pl}++;
4131             sleep 3;
4132
4133             # Writing our own Makefile.PL
4134
4135             my $fh = FileHandle->new;
4136             $fh->open(">$mpl")
4137                 or Carp::croak("Could not open >$mpl: $!");
4138             $fh->print(
4139 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
4140 # because there was no Makefile.PL supplied.
4141 # Autogenerated on: }.scalar localtime().qq{
4142
4143 use ExtUtils::MakeMaker;
4144 WriteMakefile(NAME => q[$cf]);
4145
4146 });
4147             $fh->close;
4148         }
4149     }
4150
4151     return $self;
4152 }
4153
4154 # CPAN::Distribution::untar_me ;
4155 sub untar_me {
4156     my($self,$ct) = @_;
4157     $self->{archived} = "tar";
4158     if ($ct->untar()) {
4159         $self->{unwrapped} = "YES";
4160     } else {
4161         $self->{unwrapped} = "NO";
4162     }
4163 }
4164
4165 # CPAN::Distribution::unzip_me ;
4166 sub unzip_me {
4167     my($self,$ct) = @_;
4168     $self->{archived} = "zip";
4169     if ($ct->unzip()) {
4170         $self->{unwrapped} = "YES";
4171     } else {
4172         $self->{unwrapped} = "NO";
4173     }
4174     return;
4175 }
4176
4177 sub pm2dir_me {
4178     my($self,$local_file) = @_;
4179     $self->{archived} = "pm";
4180     my $to = File::Basename::basename($local_file);
4181     if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
4182         if (CPAN::Tarzip->new($local_file)->gunzip($to)) {
4183             $self->{unwrapped} = "YES";
4184         } else {
4185             $self->{unwrapped} = "NO";
4186         }
4187     } else {
4188         File::Copy::cp($local_file,".");
4189         $self->{unwrapped} = "YES";
4190     }
4191 }
4192
4193 #-> sub CPAN::Distribution::new ;
4194 sub new {
4195     my($class,%att) = @_;
4196
4197     # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
4198
4199     my $this = { %att };
4200     return bless $this, $class;
4201 }
4202
4203 #-> sub CPAN::Distribution::look ;
4204 sub look {
4205     my($self) = @_;
4206
4207     if ($^O eq 'MacOS') {
4208       $self->Mac::BuildTools::look;
4209       return;
4210     }
4211
4212     if (  $CPAN::Config->{'shell'} ) {
4213         $CPAN::Frontend->myprint(qq{
4214 Trying to open a subshell in the build directory...
4215 });
4216     } else {
4217         $CPAN::Frontend->myprint(qq{
4218 Your configuration does not define a value for subshells.
4219 Please define it with "o conf shell <your shell>"
4220 });
4221         return;
4222     }
4223     my $dist = $self->id;
4224     my $dir;
4225     unless ($dir = $self->dir) {
4226         $self->get;
4227     }
4228     unless ($dir ||= $self->dir) {
4229         $CPAN::Frontend->mywarn(qq{
4230 Could not determine which directory to use for looking at $dist.
4231 });
4232         return;
4233     }
4234     my $pwd  = CPAN::anycwd();
4235     $self->safe_chdir($dir);
4236     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4237     unless (system($CPAN::Config->{'shell'}) == 0) {
4238         my $code = $? >> 8;
4239         $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
4240     }
4241     $self->safe_chdir($pwd);
4242 }
4243
4244 # CPAN::Distribution::cvs_import ;
4245 sub cvs_import {
4246     my($self) = @_;
4247     $self->get;
4248     my $dir = $self->dir;
4249
4250     my $package = $self->called_for;
4251     my $module = $CPAN::META->instance('CPAN::Module', $package);
4252     my $version = $module->cpan_version;
4253
4254     my $userid = $self->cpan_userid;
4255
4256     my $cvs_dir = (split /\//, $dir)[-1];
4257     $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
4258     my $cvs_root =
4259       $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
4260     my $cvs_site_perl =
4261       $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
4262     if ($cvs_site_perl) {
4263         $cvs_dir = "$cvs_site_perl/$cvs_dir";
4264     }
4265     my $cvs_log = qq{"imported $package $version sources"};
4266     $version =~ s/\./_/g;
4267     my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
4268                "$cvs_dir", $userid, "v$version");
4269
4270     my $pwd  = CPAN::anycwd();
4271     chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
4272
4273     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4274
4275     $CPAN::Frontend->myprint(qq{@cmd\n});
4276     system(@cmd) == 0 or
4277         $CPAN::Frontend->mydie("cvs import failed");
4278     chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
4279 }
4280
4281 #-> sub CPAN::Distribution::readme ;
4282 sub readme {
4283     my($self) = @_;
4284     my($dist) = $self->id;
4285     my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
4286     $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
4287     my($local_file);
4288     my($local_wanted) =
4289          File::Spec->catfile(
4290                              $CPAN::Config->{keep_source_where},
4291                              "authors",
4292                              "id",
4293                              split(/\//,"$sans.readme"),
4294                             );
4295     $self->debug("Doing localize") if $CPAN::DEBUG;
4296     $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
4297                                       $local_wanted)
4298         or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
4299
4300     if ($^O eq 'MacOS') {
4301         Mac::BuildTools::launch_file($local_file);
4302         return;
4303     }
4304
4305     my $fh_pager = FileHandle->new;
4306     local($SIG{PIPE}) = "IGNORE";
4307     $fh_pager->open("|$CPAN::Config->{'pager'}")
4308         or die "Could not open pager $CPAN::Config->{'pager'}: $!";
4309     my $fh_readme = FileHandle->new;
4310     $fh_readme->open($local_file)
4311         or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
4312     $CPAN::Frontend->myprint(qq{
4313 Displaying file
4314   $local_file
4315 with pager "$CPAN::Config->{'pager'}"
4316 });
4317     sleep 2;
4318     $fh_pager->print(<$fh_readme>);
4319     $fh_pager->close;
4320 }
4321
4322 #-> sub CPAN::Distribution::verifyCHECKSUM ;
4323 sub verifyCHECKSUM {
4324     my($self) = @_;
4325   EXCUSE: {
4326         my @e;
4327         $self->{CHECKSUM_STATUS} ||= "";
4328         $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
4329         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
4330     }
4331     my($lc_want,$lc_file,@local,$basename);
4332     @local = split(/\//,$self->id);
4333     pop @local;
4334     push @local, "CHECKSUMS";
4335     $lc_want =
4336         File::Spec->catfile($CPAN::Config->{keep_source_where},
4337                             "authors", "id", @local);
4338     local($") = "/";
4339     if (
4340         -s $lc_want
4341         &&
4342         $self->CHECKSUM_check_file($lc_want)
4343        ) {
4344         return $self->{CHECKSUM_STATUS} = "OK";
4345     }
4346     $lc_file = CPAN::FTP->localize("authors/id/@local",
4347                                    $lc_want,1);
4348     unless ($lc_file) {
4349         $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
4350         $local[-1] .= ".gz";
4351         $lc_file = CPAN::FTP->localize("authors/id/@local",
4352                                        "$lc_want.gz",1);
4353         if ($lc_file) {
4354             $lc_file =~ s/\.gz(?!\n)\Z//;
4355             CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file);
4356         } else {
4357             return;
4358         }
4359     }
4360     $self->CHECKSUM_check_file($lc_file);
4361 }
4362
4363 sub SIG_check_file {
4364     my($self,$chk_file) = @_;
4365     my $rv = eval { Module::Signature::_verify($chk_file) };
4366
4367     if ($rv == Module::Signature::SIGNATURE_OK()) {
4368         $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
4369         return $self->{SIG_STATUS} = "OK";
4370     } else {
4371         $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
4372                                  qq{distribution file. }.
4373                                  qq{Please investigate.\n\n}.
4374                                  $self->as_string,
4375                                 $CPAN::META->instance(
4376                                                         'CPAN::Author',
4377                                                         $self->cpan_userid
4378                                                         )->as_string);
4379
4380         my $wrap = qq{I\'d recommend removing $chk_file. Its signature
4381 is invalid. Maybe you have configured your 'urllist' with
4382 a bad URL. Please check this array with 'o conf urllist', and
4383 retry.};
4384
4385         $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
4386     }
4387 }
4388
4389 #-> sub CPAN::Distribution::CHECKSUM_check_file ;
4390 sub CHECKSUM_check_file {
4391     my($self,$chk_file) = @_;
4392     my($cksum,$file,$basename);
4393
4394     if ($CPAN::META->has_inst("Module::Signature") and Module::Signature->VERSION >= 0.26) {
4395         $self->debug("Module::Signature is installed, verifying");
4396         $self->SIG_check_file($chk_file);
4397     } else {
4398         $self->debug("Module::Signature is NOT installed");
4399     }
4400
4401     $file = $self->{localfile};
4402     $basename = File::Basename::basename($file);
4403     my $fh = FileHandle->new;
4404     if (open $fh, $chk_file){
4405         local($/);
4406         my $eval = <$fh>;
4407         $eval =~ s/\015?\012/\n/g;
4408         close $fh;
4409         my($comp) = Safe->new();
4410         $cksum = $comp->reval($eval);
4411         if ($@) {
4412             rename $chk_file, "$chk_file.bad";
4413             Carp::confess($@) if $@;
4414         }
4415     } else {
4416         Carp::carp "Could not open $chk_file for reading";
4417     }
4418
4419     if (exists $cksum->{$basename}{sha256}) {
4420         $self->debug("Found checksum for $basename:" .
4421                      "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
4422
4423         open($fh, $file);
4424         binmode $fh;
4425         my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
4426         $fh->close;
4427         $fh = CPAN::Tarzip->TIEHANDLE($file);
4428
4429         unless ($eq) {
4430           my $dg = Digest::SHA->new(256);
4431           my($data,$ref);
4432           $ref = \$data;
4433           while ($fh->READ($ref, 4096) > 0){
4434             $dg->add($data);
4435           }
4436           my $hexdigest = $dg->hexdigest;
4437           $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
4438         }
4439
4440         if ($eq) {
4441           $CPAN::Frontend->myprint("Checksum for $file ok\n");
4442           return $self->{CHECKSUM_STATUS} = "OK";
4443         } else {
4444             $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
4445                                      qq{distribution file. }.
4446                                      qq{Please investigate.\n\n}.
4447                                      $self->as_string,
4448                                      $CPAN::META->instance(
4449                                                            'CPAN::Author',
4450                                                            $self->cpan_userid
4451                                                           )->as_string);
4452
4453             my $wrap = qq{I\'d recommend removing $file. Its
4454 checksum is incorrect. Maybe you have configured your 'urllist' with
4455 a bad URL. Please check this array with 'o conf urllist', and
4456 retry.};
4457
4458             $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
4459
4460             # former versions just returned here but this seems a
4461             # serious threat that deserves a die
4462
4463             # $CPAN::Frontend->myprint("\n\n");
4464             # sleep 3;
4465             # return;
4466         }
4467         # close $fh if fileno($fh);
4468     } else {
4469         $self->{CHECKSUM_STATUS} ||= "";
4470         if ($self->{CHECKSUM_STATUS} eq "NIL") {
4471             $CPAN::Frontend->mywarn(qq{
4472 Warning: No checksum for $basename in $chk_file.
4473
4474 The cause for this may be that the file is very new and the checksum
4475 has not yet been calculated, but it may also be that something is
4476 going awry right now.
4477 });
4478             my $answer = ExtUtils::MakeMaker::prompt("Proceed?", "yes");
4479             $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.");
4480         }
4481         $self->{CHECKSUM_STATUS} = "NIL";
4482         return;
4483     }
4484 }
4485
4486 #-> sub CPAN::Distribution::eq_CHECKSUM ;
4487 sub eq_CHECKSUM {
4488     my($self,$fh,$expect) = @_;
4489     my $dg = Digest::SHA->new(256);
4490     my($data);
4491     while (read($fh, $data, 4096)){
4492       $dg->add($data);
4493     }
4494     my $hexdigest = $dg->hexdigest;
4495     # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
4496     $hexdigest eq $expect;
4497 }
4498
4499 #-> sub CPAN::Distribution::force ;
4500
4501 # Both CPAN::Modules and CPAN::Distributions know if "force" is in
4502 # effect by autoinspection, not by inspecting a global variable. One
4503 # of the reason why this was chosen to work that way was the treatment
4504 # of dependencies. They should not automatically inherit the force
4505 # status. But this has the downside that ^C and die() will return to
4506 # the prompt but will not be able to reset the force_update
4507 # attributes. We try to correct for it currently in the read_metadata
4508 # routine, and immediately before we check for a Signal. I hope this
4509 # works out in one of v1.57_53ff
4510
4511 sub force {
4512   my($self, $method) = @_;
4513   for my $att (qw(
4514   CHECKSUM_STATUS archived build_dir localfile make install unwrapped
4515   writemakefile
4516  )) {
4517     delete $self->{$att};
4518   }
4519   if ($method && $method eq "install") {
4520     $self->{"force_update"}++; # name should probably have been force_install
4521   }
4522 }
4523
4524 sub notest {
4525   my($self, $method) = @_;
4526   # warn "XDEBUG: set notest for $self $method";
4527   $self->{"notest"}++; # name should probably have been force_install
4528 }
4529
4530 sub unnotest {
4531   my($self) = @_;
4532   # warn "XDEBUG: deleting notest";
4533   delete $self->{'notest'};
4534 }
4535
4536 #-> sub CPAN::Distribution::unforce ;
4537 sub unforce {
4538   my($self) = @_;
4539   delete $self->{'force_update'};
4540 }
4541
4542 #-> sub CPAN::Distribution::isa_perl ;
4543 sub isa_perl {
4544   my($self) = @_;
4545   my $file = File::Basename::basename($self->id);
4546   if ($file =~ m{ ^ perl
4547                   -?
4548                   (5)
4549                   ([._-])
4550                   (
4551                    \d{3}(_[0-4][0-9])?
4552                    |
4553                    \d*[24680]\.\d+
4554                   )
4555                   \.tar[._-]gz
4556                   (?!\n)\Z
4557                 }xs){
4558     return "$1.$3";
4559   } elsif ($self->cpan_comment
4560            &&
4561            $self->cpan_comment =~ /isa_perl\(.+?\)/){
4562     return $1;
4563   }
4564 }
4565
4566
4567 #-> sub CPAN::Distribution::perl ;
4568 sub perl {
4569     return $CPAN::Perl;
4570 }
4571
4572
4573 #-> sub CPAN::Distribution::make ;
4574 sub make {
4575     my($self) = @_;
4576     my $make = $self->{modulebuild} ? "Build" : "make";
4577     $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
4578     # Emergency brake if they said install Pippi and get newest perl
4579     if ($self->isa_perl) {
4580       if (
4581           $self->called_for ne $self->id &&
4582           ! $self->{force_update}
4583          ) {
4584         # if we die here, we break bundles
4585         $CPAN::Frontend->mywarn(sprintf qq{
4586 The most recent version "%s" of the module "%s"
4587 comes with the current version of perl (%s).
4588 I\'ll build that only if you ask for something like
4589     force install %s
4590 or
4591     install %s
4592 },
4593                                $CPAN::META->instance(
4594                                                      'CPAN::Module',
4595                                                      $self->called_for
4596                                                     )->cpan_version,
4597                                $self->called_for,
4598                                $self->isa_perl,
4599                                $self->called_for,
4600                                $self->id);
4601         sleep 5; return;
4602       }
4603     }
4604     $self->get;
4605   EXCUSE: {
4606         my @e;
4607         !$self->{archived} || $self->{archived} eq "NO" and push @e,
4608         "Is neither a tar nor a zip archive.";
4609
4610         !$self->{unwrapped} || $self->{unwrapped} eq "NO" and push @e,
4611         "had problems unarchiving. Please build manually";
4612
4613         exists $self->{writemakefile} &&
4614             $self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e,
4615                 $1 || "Had some problem writing Makefile";
4616
4617         defined $self->{'make'} and push @e,
4618             "Has already been processed within this session";
4619
4620         exists $self->{later} and length($self->{later}) and
4621             push @e, $self->{later};
4622
4623         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
4624     }
4625     $CPAN::Frontend->myprint("\n  CPAN.pm: Going to build ".$self->id."\n\n");
4626     my $builddir = $self->dir or
4627         $CPAN::Frontend->mydie("PANIC: Cannot determine build directory");
4628     chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
4629     $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
4630
4631     if ($^O eq 'MacOS') {
4632         Mac::BuildTools::make($self);
4633         return;
4634     }
4635
4636     my $system;
4637     if ($self->{'configure'}) {
4638         $system = $self->{'configure'};
4639     } elsif ($self->{modulebuild}) {
4640         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
4641         $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}";
4642     } else {
4643         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
4644         my $switch = "";
4645 # This needs a handler that can be turned on or off:
4646 #       $switch = "-MExtUtils::MakeMaker ".
4647 #           "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
4648 #           if $] > 5.00310;
4649         $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
4650     }
4651     unless (exists $self->{writemakefile}) {
4652         local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
4653         my($ret,$pid);
4654         $@ = "";
4655         if ($CPAN::Config->{inactivity_timeout}) {
4656             eval {
4657                 alarm $CPAN::Config->{inactivity_timeout};
4658                 local $SIG{CHLD}; # = sub { wait };
4659                 if (defined($pid = fork)) {
4660                     if ($pid) { #parent
4661                         # wait;
4662                         waitpid $pid, 0;
4663                     } else {    #child
4664                         # note, this exec isn't necessary if
4665                         # inactivity_timeout is 0. On the Mac I'd
4666                         # suggest, we set it always to 0.
4667                         exec $system;
4668                     }
4669                 } else {
4670                     $CPAN::Frontend->myprint("Cannot fork: $!");
4671                     return;
4672                 }
4673             };
4674             alarm 0;
4675             if ($@){
4676                 kill 9, $pid;
4677                 waitpid $pid, 0;
4678                 $CPAN::Frontend->myprint($@);
4679                 $self->{writemakefile} = "NO $@";
4680                 $@ = "";
4681                 return;
4682             }
4683         } else {
4684           $ret = system($system);
4685           if ($ret != 0) {
4686             $self->{writemakefile} = "NO Makefile.PL returned status $ret";
4687             return;
4688           }
4689         }
4690         if (-f "Makefile" || -f "Build") {
4691           $self->{writemakefile} = "YES";
4692           delete $self->{make_clean}; # if cleaned before, enable next
4693         } else {
4694           $self->{writemakefile} =
4695               qq{NO Makefile.PL refused to write a Makefile.};
4696           # It's probably worth it to record the reason, so let's retry
4697           # local $/;
4698           # my $fh = IO::File->new("$system |"); # STDERR? STDIN?
4699           # $self->{writemakefile} .= <$fh>;
4700         }
4701     }
4702     if ($CPAN::Signal){
4703       delete $self->{force_update};
4704       return;
4705     }
4706     if (my @prereq = $self->unsat_prereq){
4707       return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4708     }
4709     if ($self->{modulebuild}) {
4710         $system = "./Build $CPAN::Config->{mbuild_arg}";
4711     } else {
4712         $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
4713     }
4714     if (system($system) == 0) {
4715          $CPAN::Frontend->myprint("  $system -- OK\n");
4716          $self->{'make'} = "YES";
4717     } else {
4718          $self->{writemakefile} ||= "YES";
4719          $self->{'make'} = "NO";
4720          $CPAN::Frontend->myprint("  $system -- NOT OK\n");
4721     }
4722 }
4723
4724 sub follow_prereqs {
4725     my($self) = shift;
4726     my(@prereq) = grep {$_ ne "perl"} @_;
4727     return unless @prereq;
4728     my $id = $self->id;
4729     $CPAN::Frontend->myprint("---- Unsatisfied dependencies detected ".
4730                              "during [$id] -----\n");
4731
4732     for my $p (@prereq) {
4733         $CPAN::Frontend->myprint("    $p\n");
4734     }
4735     my $follow = 0;
4736     if ($CPAN::Config->{prerequisites_policy} eq "follow") {
4737         $follow = 1;
4738     } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
4739         require ExtUtils::MakeMaker;
4740         my $answer = ExtUtils::MakeMaker::prompt(
4741 "Shall I follow them and prepend them to the queue
4742 of modules we are processing right now?", "yes");
4743         $follow = $answer =~ /^\s*y/i;
4744     } else {
4745         local($") = ", ";
4746         $CPAN::Frontend->
4747             myprint("  Ignoring dependencies on modules @prereq\n");
4748     }
4749     if ($follow) {
4750         # color them as dirty
4751         for my $p (@prereq) {
4752             # warn "calling color_cmd_tmps(0,1)";
4753             CPAN::Shell->expandany($p)->color_cmd_tmps(0,1);
4754         }
4755         CPAN::Queue->jumpqueue(@prereq,$id); # queue them and requeue yourself
4756         $self->{later} = "Delayed until after prerequisites";
4757         return 1; # signal success to the queuerunner
4758     }
4759 }
4760
4761 #-> sub CPAN::Distribution::unsat_prereq ;
4762 sub unsat_prereq {
4763     my($self) = @_;
4764     my $prereq_pm = $self->prereq_pm or return;
4765     my(@need);
4766   NEED: while (my($need_module, $need_version) = each %$prereq_pm) {
4767         my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
4768         # we were too demanding:
4769         next if $nmo->uptodate;
4770
4771         # if they have not specified a version, we accept any installed one
4772         if (not defined $need_version or
4773            $need_version eq "0" or
4774            $need_version eq "undef") {
4775             next if defined $nmo->inst_file;
4776         }
4777
4778         # We only want to install prereqs if either they're not installed
4779         # or if the installed version is too old. We cannot omit this
4780         # check, because if 'force' is in effect, nobody else will check.
4781         if (defined $nmo->inst_file) {
4782             my(@all_requirements) = split /\s*,\s*/, $need_version;
4783             local($^W) = 0;
4784             my $ok = 0;
4785           RQ: for my $rq (@all_requirements) {
4786                 if ($rq =~ s|>=\s*||) {
4787                 } elsif ($rq =~ s|>\s*||) {
4788                     # 2005-12: one user
4789                     if (CPAN::Version->vgt($nmo->inst_version,$rq)){
4790                         $ok++;
4791                     }
4792                     next RQ;
4793                 } elsif ($rq =~ s|!=\s*||) {
4794                     # 2005-12: no user
4795                     if (CPAN::Version->vcmp($nmo->inst_version,$rq)){
4796                         $ok++;
4797                         next RQ;
4798                     } else {
4799                         last RQ;
4800                     }
4801                 } elsif ($rq =~ m|<=?\s*|) {
4802                     # 2005-12: no user
4803                     $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])");
4804                     $ok++;
4805                     next RQ;
4806                 }
4807                 if (! CPAN::Version->vgt($rq, $nmo->inst_version)){
4808                     $ok++;
4809                 }
4810                 CPAN->debug(sprintf "id[%s]inst_file[%s]inst_version[%s]rq[%s]ok[%d]",
4811                             $nmo->id,
4812                             $nmo->inst_file,
4813                             $nmo->inst_version,
4814                             CPAN::Version->readable($rq),
4815                             $ok,
4816                            ) if $CPAN::DEBUG;
4817             }
4818             next NEED if $ok == @all_requirements;
4819         }
4820
4821         if ($self->{sponsored_mods}{$need_module}++){
4822             # We have already sponsored it and for some reason it's still
4823             # not available. So we do nothing. Or what should we do?
4824             # if we push it again, we have a potential infinite loop
4825             next;
4826         }
4827         push @need, $need_module;
4828     }
4829     @need;
4830 }
4831
4832 #-> sub CPAN::Distribution::read_yaml ;
4833 sub read_yaml {
4834     my($self) = @_;
4835     return $self->{yaml_content} if exists $self->{yaml_content};
4836     my $build_dir = $self->{build_dir};
4837     my $yaml = File::Spec->catfile($build_dir,"META.yml");
4838     return unless -f $yaml;
4839     if ($CPAN::META->has_inst("YAML")) {
4840         eval { $self->{yaml_content} = YAML::LoadFile($yaml); };
4841         if ($@) {
4842             $CPAN::Frontend->mywarn("Error while parsing META.yml: $@");
4843             return;
4844         }
4845     }
4846     return $self->{yaml_content};
4847 }
4848
4849 #-> sub CPAN::Distribution::prereq_pm ;
4850 sub prereq_pm {
4851     my($self) = @_;
4852     return $self->{prereq_pm} if
4853         exists $self->{prereq_pm_detected} && $self->{prereq_pm_detected};
4854     return unless $self->{writemakefile}  # no need to have succeeded
4855                                           # but we must have run it
4856         || $self->{mudulebuild};
4857     my $req;
4858     if (my $yaml = $self->read_yaml) {
4859         $req =  $yaml->{requires};
4860         undef $req unless ref $req eq "HASH" && %$req;
4861         if ($req) {
4862             if ($yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
4863                 my $eummv = do { local $^W = 0; $1+0; };
4864                 if ($eummv < 6.2501) {
4865                     # thanks to Slaven for digging that out: MM before
4866                     # that could be wrong because it could reflect a
4867                     # previous release
4868                     undef $req;
4869                 }
4870             }
4871             my $areq;
4872             my $do_replace;
4873             while (my($k,$v) = each %$req) {
4874                 if ($v =~ /\d/) {
4875                     $areq->{$k} = $v;
4876                 } elsif ($k =~ /[A-Za-z]/ &&
4877                          $v =~ /[A-Za-z]/ &&
4878                          $CPAN::META->exists("Module",$v)
4879                         ) {
4880                     $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
4881                                             "requires hash: $k => $v; I'll take both ".
4882                                             "key and value as a module name\n");
4883                     sleep 1;
4884                     $areq->{$k} = 0;
4885                     $areq->{$v} = 0;
4886                     $do_replace++;
4887                 }
4888             }
4889             $req = $areq if $do_replace;
4890         }
4891         if ($req) {
4892             delete $req->{perl};
4893         }
4894     }
4895     unless ($req) {
4896         my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
4897         my $makefile = File::Spec->catfile($build_dir,"Makefile");
4898         my $fh;
4899         if (-f $makefile
4900             and
4901             $fh = FileHandle->new("<$makefile\0")) {
4902             local($/) = "\n";
4903             while (<$fh>) {
4904                 last if /MakeMaker post_initialize section/;
4905                 my($p) = m{^[\#]
4906                            \s+PREREQ_PM\s+=>\s+(.+)
4907                        }x;
4908                 next unless $p;
4909                 # warn "Found prereq expr[$p]";
4910
4911                 #  Regexp modified by A.Speer to remember actual version of file
4912                 #  PREREQ_PM hash key wants, then add to
4913                 while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
4914                     # In case a prereq is mentioned twice, complain.
4915                     if ( defined $req->{$1} ) {
4916                         warn "Warning: PREREQ_PM mentions $1 more than once, ".
4917                             "last mention wins";
4918                     }
4919                     $req->{$1} = $2;
4920                 }
4921                 last;
4922             }
4923         }
4924     }
4925     $self->{prereq_pm_detected}++;
4926     return $self->{prereq_pm} = $req;
4927 }
4928
4929 #-> sub CPAN::Distribution::test ;
4930 sub test {
4931     my($self) = @_;
4932     $self->make;
4933     if ($CPAN::Signal){
4934       delete $self->{force_update};
4935       return;
4936     }
4937     # warn "XDEBUG: checking for notest: $self->{notest} $self";
4938     if ($self->{notest}) {
4939         $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
4940         return 1;
4941     }
4942
4943     my $make = $self->{modulebuild} ? "Build" : "make";
4944     $CPAN::Frontend->myprint("Running $make test\n");
4945     if (my @prereq = $self->unsat_prereq){
4946       return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4947     }
4948   EXCUSE: {
4949         my @e;
4950         exists $self->{make} or exists $self->{later} or push @e,
4951         "Make had some problems, maybe interrupted? Won't test";
4952
4953         exists $self->{'make'} and
4954             $self->{'make'} eq 'NO' and
4955                 push @e, "Can't test without successful make";
4956
4957         exists $self->{build_dir} or push @e, "Has no own directory";
4958         $self->{badtestcnt} ||= 0;
4959         $self->{badtestcnt} > 0 and
4960             push @e, "Won't repeat unsuccessful test during this command";
4961
4962         exists $self->{later} and length($self->{later}) and
4963             push @e, $self->{later};
4964
4965         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
4966     }
4967     chdir $self->{'build_dir'} or
4968         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4969     $self->debug("Changed directory to $self->{'build_dir'}")
4970         if $CPAN::DEBUG;
4971
4972     if ($^O eq 'MacOS') {
4973         Mac::BuildTools::make_test($self);
4974         return;
4975     }
4976
4977     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
4978                            ? $ENV{PERL5LIB}
4979                            : ($ENV{PERLLIB} || "");
4980
4981     $CPAN::META->set_perl5lib;
4982     my $system;
4983     if ($self->{modulebuild}) {
4984         $system = "./Build test";
4985     } else {
4986         $system = join " ", $CPAN::Config->{'make'}, "test";
4987     }
4988     if (system($system) == 0) {
4989          $CPAN::Frontend->myprint("  $system -- OK\n");
4990          $CPAN::META->is_tested($self->{'build_dir'});
4991          $self->{make_test} = "YES";
4992     } else {
4993          $self->{make_test} = "NO";
4994          $self->{badtestcnt}++;
4995          $CPAN::Frontend->myprint("  $system -- NOT OK\n");
4996     }
4997 }
4998
4999 #-> sub CPAN::Distribution::clean ;
5000 sub clean {
5001     my($self) = @_;
5002     my $make = $self->{modulebuild} ? "Build" : "make";
5003     $CPAN::Frontend->myprint("Running $make clean\n");
5004     unless (exists $self->{build_dir}) {
5005         $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
5006         return 1;
5007     }
5008   EXCUSE: {
5009         my @e;
5010         exists $self->{make_clean} and $self->{make_clean} eq "YES" and
5011             push @e, "make clean already called once";
5012         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
5013     }
5014     chdir $self->{'build_dir'} or
5015         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
5016     $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
5017
5018     if ($^O eq 'MacOS') {
5019         Mac::BuildTools::make_clean($self);
5020         return;
5021     }
5022
5023     my $system;
5024     if ($self->{modulebuild}) {
5025         $system = "./Build clean";
5026     } else {
5027         $system  = join " ", $CPAN::Config->{'make'}, "clean";
5028     }
5029     if (system($system) == 0) {
5030       $CPAN::Frontend->myprint("  $system -- OK\n");
5031
5032       # $self->force;
5033
5034       # Jost Krieger pointed out that this "force" was wrong because
5035       # it has the effect that the next "install" on this distribution
5036       # will untar everything again. Instead we should bring the
5037       # object's state back to where it is after untarring.
5038
5039       for my $k (qw(
5040                     force_update
5041                     install
5042                     writemakefile
5043                     make
5044                     make_test
5045                    )) {
5046           delete $self->{$k};
5047       }
5048       $self->{make_clean} = "YES";
5049
5050     } else {
5051       # Hmmm, what to do if make clean failed?
5052
5053       $CPAN::Frontend->myprint(qq{  $system -- NOT OK
5054
5055 make clean did not succeed, marking directory as unusable for further work.
5056 });
5057       $self->force("make"); # so that this directory won't be used again
5058
5059     }
5060 }
5061
5062 #-> sub CPAN::Distribution::install ;
5063 sub install {
5064     my($self) = @_;
5065     $self->test;
5066     if ($CPAN::Signal){
5067       delete $self->{force_update};
5068       return;
5069     }
5070     my $make = $self->{modulebuild} ? "Build" : "make";
5071     $CPAN::Frontend->myprint("Running $make install\n");
5072   EXCUSE: {
5073         my @e;
5074         exists $self->{build_dir} or push @e, "Has no own directory";
5075
5076         exists $self->{make} or exists $self->{later} or push @e,
5077         "Make had some problems, maybe interrupted? Won't install";
5078
5079         exists $self->{'make'} and
5080             $self->{'make'} eq 'NO' and
5081                 push @e, "make had returned bad status, install seems impossible";
5082
5083         push @e, "make test had returned bad status, ".
5084             "won't install without force"
5085             if exists $self->{'make_test'} and
5086             $self->{'make_test'} eq 'NO' and
5087             ! $self->{'force_update'};
5088
5089         exists $self->{'install'} and push @e,
5090         $self->{'install'} eq "YES" ?
5091             "Already done" : "Already tried without success";
5092
5093         exists $self->{later} and length($self->{later}) and
5094             push @e, $self->{later};
5095
5096         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
5097     }
5098     chdir $self->{'build_dir'} or
5099         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
5100     $self->debug("Changed directory to $self->{'build_dir'}")
5101         if $CPAN::DEBUG;
5102
5103     if ($^O eq 'MacOS') {
5104         Mac::BuildTools::make_install($self);
5105         return;
5106     }
5107
5108     my $system;
5109     if ($self->{modulebuild}) {
5110         my($mbuild_install_build_command) = $CPAN::Config->{'mbuild_install_build_command'} ||
5111             "./Build";
5112         $system = join(" ",
5113                        $mbuild_install_build_command,
5114                        "install",
5115                        $CPAN::Config->{mbuild_install_arg},
5116                       );
5117     } else {
5118         my($make_install_make_command) = $CPAN::Config->{'make_install_make_command'} ||
5119             $CPAN::Config->{'make'};
5120         $system = join(" ",
5121                        $make_install_make_command,
5122                        "install",
5123                        $CPAN::Config->{make_install_arg},
5124                       );
5125     }
5126
5127     my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 ";
5128     my($pipe) = FileHandle->new("$system $stderr |");
5129     my($makeout) = "";
5130     while (<$pipe>){
5131         $CPAN::Frontend->myprint($_);
5132         $makeout .= $_;
5133     }
5134     $pipe->close;
5135     if ($?==0) {
5136          $CPAN::Frontend->myprint("  $system -- OK\n");
5137          $CPAN::META->is_installed($self->{'build_dir'});
5138          return $self->{'install'} = "YES";
5139     } else {
5140          $self->{'install'} = "NO";
5141          $CPAN::Frontend->myprint("  $system -- NOT OK\n");
5142          if (
5143              $makeout =~ /permission/s
5144              && $> > 0
5145              && (
5146                  ! $CPAN::Config->{make_install_make_command}
5147                  || $CPAN::Config->{make_install_make_command} eq $CPAN::Config->{make}
5148                 )
5149             ) {
5150              $CPAN::Frontend->myprint(
5151                                       qq{----\n}.
5152                                       qq{  You may have to su }.
5153                                       qq{to root to install the package\n}.
5154                                       qq{  (Or you may want to run something like\n}.
5155                                       qq{    o conf make_install_make_command 'sudo make'\n}.
5156                                       qq{  to raise your permissions.}
5157                                      );
5158          }
5159     }
5160     delete $self->{force_update};
5161 }
5162
5163 #-> sub CPAN::Distribution::dir ;
5164 sub dir {
5165     shift->{'build_dir'};
5166 }
5167
5168 #-> sub CPAN::Distribution::perldoc ;
5169 sub perldoc {
5170     my($self) = @_;
5171
5172     my($dist) = $self->id;
5173     my $package = $self->called_for;
5174
5175     $self->_display_url( $CPAN::Defaultdocs . $package );
5176 }
5177
5178 #-> sub CPAN::Distribution::_check_binary ;
5179 sub _check_binary {
5180     my ($dist,$shell,$binary) = @_;
5181     my ($pid,$readme,$out);
5182
5183     $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
5184       if $CPAN::DEBUG;
5185
5186     $pid = open $readme, "which $binary|"
5187       or $CPAN::Frontend->mydie(qq{Could not fork 'which $binary': $!});
5188     while (<$readme>) {
5189         $out .= $_;
5190     }
5191     close $readme or die "Could not run 'which $binary': $!";
5192
5193     $CPAN::Frontend->myprint(qq{   + $out \n})
5194       if $CPAN::DEBUG && $out;
5195
5196     return $out;
5197 }
5198
5199 #-> sub CPAN::Distribution::_display_url ;
5200 sub _display_url {
5201     my($self,$url) = @_;
5202     my($res,$saved_file,$pid,$readme,$out);
5203
5204     $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
5205       if $CPAN::DEBUG;
5206
5207     # should we define it in the config instead?
5208     my $html_converter = "html2text";
5209
5210     my $web_browser = $CPAN::Config->{'lynx'} || undef;
5211     my $web_browser_out = $web_browser
5212       ? CPAN::Distribution->_check_binary($self,$web_browser)
5213         : undef;
5214
5215     my ($tmpout,$tmperr);
5216     if (not $web_browser_out) {
5217         # web browser not found, let's try text only
5218         my $html_converter_out =
5219           CPAN::Distribution->_check_binary($self,$html_converter);
5220
5221         if ($html_converter_out ) {
5222             # html2text found, run it
5223             $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
5224             $CPAN::Frontend->myprint(qq{ERROR: problems while getting $url, $!\n})
5225               unless defined($saved_file);
5226
5227             $pid = open $readme, "$html_converter $saved_file |"
5228               or $CPAN::Frontend->mydie(qq{
5229 Could not fork '$html_converter $saved_file': $!});
5230             my $fh = File::Temp->new(
5231                                      template => 'cpan_htmlconvert_XXXX',
5232                                      suffix => '.txt',
5233                                      unlink => 0,
5234                                     );
5235             while (<$readme>) {
5236                 $fh->print($_);
5237             }
5238             close $readme
5239               or $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
5240             my $tmpin = $fh->filename;
5241             $CPAN::Frontend->myprint(sprintf(qq{
5242 Run '%s %s' and
5243 saved output to %s\n},
5244                                              $html_converter,
5245                                              $saved_file,
5246                                              $tmpin,
5247                                             )) if $CPAN::DEBUG;
5248             close $fh; undef $fh;
5249             open $fh, $tmpin
5250               or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
5251             my $fh_pager = FileHandle->new;
5252             local($SIG{PIPE}) = "IGNORE";
5253             $fh_pager->open("|$CPAN::Config->{'pager'}")
5254               or $CPAN::Frontend->mydie(qq{
5255 Could not open pager $CPAN::Config->{'pager'}: $!});
5256             $CPAN::Frontend->myprint(qq{
5257 Displaying URL
5258   $url
5259 with pager "$CPAN::Config->{'pager'}"
5260 });
5261             sleep 2;
5262             $fh_pager->print(<$fh>);
5263             $fh_pager->close;
5264         } else {
5265             # coldn't find the web browser or html converter
5266             $CPAN::Frontend->myprint(qq{
5267 You need to install lynx or $html_converter to use this feature.});
5268         }
5269     } else {
5270         # web browser found, run the action
5271         my $browser = $CPAN::Config->{'lynx'};
5272         $CPAN::Frontend->myprint(qq{system[$browser $url]})
5273           if $CPAN::DEBUG;
5274         $CPAN::Frontend->myprint(qq{
5275 Displaying URL
5276   $url
5277 with browser $browser
5278 });
5279         sleep 2;
5280         system("$browser $url");
5281         if ($saved_file) { 1 while unlink($saved_file) }
5282     }
5283 }
5284
5285 #-> sub CPAN::Distribution::_getsave_url ;
5286 sub _getsave_url {
5287     my($dist, $shell, $url) = @_;
5288
5289     $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
5290       if $CPAN::DEBUG;
5291
5292     my $fh  = File::Temp->new(
5293                               template => "cpan_getsave_url_XXXX",
5294                               suffix => ".html",
5295                               unlink => 0,
5296                              );
5297     my $tmpin = $fh->filename;
5298     if ($CPAN::META->has_usable('LWP')) {
5299         $CPAN::Frontend->myprint("Fetching with LWP:
5300   $url
5301 ");
5302         my $Ua;
5303         CPAN::LWP::UserAgent->config;
5304         eval { $Ua = CPAN::LWP::UserAgent->new; };
5305         if ($@) {
5306             $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
5307             return;
5308         } else {
5309             my($var);
5310             $Ua->proxy('http', $var)
5311                 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
5312             $Ua->no_proxy($var)
5313                 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
5314         }
5315
5316         my $req = HTTP::Request->new(GET => $url);
5317         $req->header('Accept' => 'text/html');
5318         my $res = $Ua->request($req);
5319         if ($res->is_success) {
5320             $CPAN::Frontend->myprint(" + request successful.\n")
5321                 if $CPAN::DEBUG;
5322             print $fh $res->content;
5323             close $fh;
5324             $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
5325                 if $CPAN::DEBUG;
5326             return $tmpin;
5327         } else {
5328             $CPAN::Frontend->myprint(sprintf(
5329                                              "LWP failed with code[%s], message[%s]\n",
5330                                              $res->code,
5331                                              $res->message,
5332                                             ));
5333             return;
5334         }
5335     } else {
5336         $CPAN::Frontend->myprint("LWP not available\n");
5337         return;
5338     }
5339 }
5340
5341 package CPAN::Bundle;
5342 use strict;
5343
5344 sub look {
5345     my $self = shift;
5346     $CPAN::Frontend->myprint($self->as_string);
5347 }
5348
5349 sub undelay {
5350     my $self = shift;
5351     delete $self->{later};
5352     for my $c ( $self->contains ) {
5353         my $obj = CPAN::Shell->expandany($c) or next;
5354         $obj->undelay;
5355     }
5356 }
5357
5358 # mark as dirty/clean
5359 #-> sub CPAN::Bundle::color_cmd_tmps ;
5360 sub color_cmd_tmps {
5361     my($self) = shift;
5362     my($depth) = shift || 0;
5363     my($color) = shift || 0;
5364     my($ancestors) = shift || [];
5365     # a module needs to recurse to its cpan_file, a distribution needs
5366     # to recurse into its prereq_pms, a bundle needs to recurse into its modules
5367
5368     return if exists $self->{incommandcolor}
5369         && $self->{incommandcolor}==$color;
5370     if ($depth>=100){
5371         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
5372     }
5373     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5374
5375     for my $c ( $self->contains ) {
5376         my $obj = CPAN::Shell->expandany($c) or next;
5377         CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
5378         $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5379     }
5380     if ($color==0) {
5381         delete $self->{badtestcnt};
5382     }
5383     $self->{incommandcolor} = $color;
5384 }
5385
5386 #-> sub CPAN::Bundle::as_string ;
5387 sub as_string {
5388     my($self) = @_;
5389     $self->contains;
5390     # following line must be "=", not "||=" because we have a moving target
5391     $self->{INST_VERSION} = $self->inst_version;
5392     return $self->SUPER::as_string;
5393 }
5394
5395 #-> sub CPAN::Bundle::contains ;
5396 sub contains {
5397     my($self) = @_;
5398     my($inst_file) = $self->inst_file || "";
5399     my($id) = $self->id;
5400     $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
5401     unless ($inst_file) {
5402         # Try to get at it in the cpan directory
5403         $self->debug("no inst_file") if $CPAN::DEBUG;
5404         my $cpan_file;
5405         $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
5406               $cpan_file = $self->cpan_file;
5407         if ($cpan_file eq "N/A") {
5408             $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
5409   Maybe stale symlink? Maybe removed during session? Giving up.\n");
5410         }
5411         my $dist = $CPAN::META->instance('CPAN::Distribution',
5412                                          $self->cpan_file);
5413         $dist->get;
5414         $self->debug($dist->as_string) if $CPAN::DEBUG;
5415         my($todir) = $CPAN::Config->{'cpan_home'};
5416         my(@me,$from,$to,$me);
5417         @me = split /::/, $self->id;
5418         $me[-1] .= ".pm";
5419         $me = File::Spec->catfile(@me);
5420         $from = $self->find_bundle_file($dist->{'build_dir'},$me);
5421         $to = File::Spec->catfile($todir,$me);
5422         File::Path::mkpath(File::Basename::dirname($to));
5423         File::Copy::copy($from, $to)
5424               or Carp::confess("Couldn't copy $from to $to: $!");
5425         $inst_file = $to;
5426     }
5427     my @result;
5428     my $fh = FileHandle->new;
5429     local $/ = "\n";
5430     open($fh,$inst_file) or die "Could not open '$inst_file': $!";
5431     my $in_cont = 0;
5432     $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
5433     while (<$fh>) {
5434         $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
5435             m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
5436         next unless $in_cont;
5437         next if /^=/;
5438         s/\#.*//;
5439         next if /^\s+$/;
5440         chomp;
5441         push @result, (split " ", $_, 2)[0];
5442     }
5443     close $fh;
5444     delete $self->{STATUS};
5445     $self->{CONTAINS} = \@result;
5446     $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
5447     unless (@result) {
5448         $CPAN::Frontend->mywarn(qq{
5449 The bundle file "$inst_file" may be a broken
5450 bundlefile. It seems not to contain any bundle definition.
5451 Please check the file and if it is bogus, please delete it.
5452 Sorry for the inconvenience.
5453 });
5454     }
5455     @result;
5456 }
5457
5458 #-> sub CPAN::Bundle::find_bundle_file
5459 sub find_bundle_file {
5460     my($self,$where,$what) = @_;
5461     $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
5462 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
5463 ###    my $bu = File::Spec->catfile($where,$what);
5464 ###    return $bu if -f $bu;
5465     my $manifest = File::Spec->catfile($where,"MANIFEST");
5466     unless (-f $manifest) {
5467         require ExtUtils::Manifest;
5468         my $cwd = CPAN::anycwd();
5469         chdir $where or $CPAN::Frontend->mydie(qq{Could not chdir to "$where": $!});
5470         ExtUtils::Manifest::mkmanifest();
5471         chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
5472     }
5473     my $fh = FileHandle->new($manifest)
5474         or Carp::croak("Couldn't open $manifest: $!");
5475     local($/) = "\n";
5476     my $what2 = $what;
5477     if ($^O eq 'MacOS') {
5478       $what =~ s/^://;
5479       $what =~ tr|:|/|;
5480       $what2 =~ s/:Bundle://;
5481       $what2 =~ tr|:|/|;
5482     } else {
5483         $what2 =~ s|Bundle[/\\]||;
5484     }
5485     my $bu;
5486     while (<$fh>) {
5487         next if /^\s*\#/;
5488         my($file) = /(\S+)/;
5489         if ($file =~ m|\Q$what\E$|) {
5490             $bu = $file;
5491             # return File::Spec->catfile($where,$bu); # bad
5492             last;
5493         }
5494         # retry if she managed to
5495         # have no Bundle directory
5496         $bu = $file if $file =~ m|\Q$what2\E$|;
5497     }
5498     $bu =~ tr|/|:| if $^O eq 'MacOS';
5499     return File::Spec->catfile($where, $bu) if $bu;
5500     Carp::croak("Couldn't find a Bundle file in $where");
5501 }
5502
5503 # needs to work quite differently from Module::inst_file because of
5504 # cpan_home/Bundle/ directory and the possibility that we have
5505 # shadowing effect. As it makes no sense to take the first in @INC for
5506 # Bundles, we parse them all for $VERSION and take the newest.
5507
5508 #-> sub CPAN::Bundle::inst_file ;
5509 sub inst_file {
5510     my($self) = @_;
5511     my($inst_file);
5512     my(@me);
5513     @me = split /::/, $self->id;
5514     $me[-1] .= ".pm";
5515     my($incdir,$bestv);
5516     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
5517         my $bfile = File::Spec->catfile($incdir, @me);
5518         CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
5519         next unless -f $bfile;
5520         my $foundv = MM->parse_version($bfile);
5521         if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
5522             $self->{INST_FILE} = $bfile;
5523             $self->{INST_VERSION} = $bestv = $foundv;
5524         }
5525     }
5526     $self->{INST_FILE};
5527 }
5528
5529 #-> sub CPAN::Bundle::inst_version ;
5530 sub inst_version {
5531     my($self) = @_;
5532     $self->inst_file; # finds INST_VERSION as side effect
5533     $self->{INST_VERSION};
5534 }
5535
5536 #-> sub CPAN::Bundle::rematein ;
5537 sub rematein {
5538     my($self,$meth) = @_;
5539     $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
5540     my($id) = $self->id;
5541     Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
5542         unless $self->inst_file || $self->cpan_file;
5543     my($s,%fail);
5544     for $s ($self->contains) {
5545         my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
5546             $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
5547         if ($type eq 'CPAN::Distribution') {
5548             $CPAN::Frontend->mywarn(qq{
5549 The Bundle }.$self->id.qq{ contains
5550 explicitly a file $s.
5551 });
5552             sleep 3;
5553         }
5554         # possibly noisy action:
5555         $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
5556         my $obj = $CPAN::META->instance($type,$s);
5557         $obj->$meth();
5558         if ($obj->isa('CPAN::Bundle')
5559             &&
5560             exists $obj->{install_failed}
5561             &&
5562             ref($obj->{install_failed}) eq "HASH"
5563            ) {
5564           for (keys %{$obj->{install_failed}}) {
5565             $self->{install_failed}{$_} = undef; # propagate faiure up
5566                                                  # to me in a
5567                                                  # recursive call
5568             $fail{$s} = 1; # the bundle itself may have succeeded but
5569                            # not all children
5570           }
5571         } else {
5572           my $success;
5573           $success = $obj->can("uptodate") ? $obj->uptodate : 0;
5574           $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
5575           if ($success) {
5576             delete $self->{install_failed}{$s};
5577           } else {
5578             $fail{$s} = 1;
5579           }
5580         }
5581     }
5582
5583     # recap with less noise
5584     if ( $meth eq "install" ) {
5585         if (%fail) {
5586             require Text::Wrap;
5587             my $raw = sprintf(qq{Bundle summary:
5588 The following items in bundle %s had installation problems:},
5589                               $self->id
5590                              );
5591             $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
5592             $CPAN::Frontend->myprint("\n");
5593             my $paragraph = "";
5594             my %reported;
5595             for $s ($self->contains) {
5596               if ($fail{$s}){
5597                 $paragraph .= "$s ";
5598                 $self->{install_failed}{$s} = undef;
5599                 $reported{$s} = undef;
5600               }
5601             }
5602             my $report_propagated;
5603             for $s (sort keys %{$self->{install_failed}}) {
5604               next if exists $reported{$s};
5605               $paragraph .= "and the following items had problems
5606 during recursive bundle calls: " unless $report_propagated++;
5607               $paragraph .= "$s ";
5608             }
5609             $CPAN::Frontend->myprint(Text::Wrap::fill("  ","  ",$paragraph));
5610             $CPAN::Frontend->myprint("\n");
5611         } else {
5612             $self->{'install'} = 'YES';
5613         }
5614     }
5615 }
5616
5617 #sub CPAN::Bundle::xs_file
5618 sub xs_file {
5619     # If a bundle contains another that contains an xs_file we have
5620     # here, we just don't bother I suppose
5621     return 0;
5622 }
5623
5624 #-> sub CPAN::Bundle::force ;
5625 sub force   { shift->rematein('force',@_); }
5626 #-> sub CPAN::Bundle::notest ;
5627 sub notest  { shift->rematein('notest',@_); }
5628 #-> sub CPAN::Bundle::get ;
5629 sub get     { shift->rematein('get',@_); }
5630 #-> sub CPAN::Bundle::make ;
5631 sub make    { shift->rematein('make',@_); }
5632 #-> sub CPAN::Bundle::test ;
5633 sub test    {
5634     my $self = shift;
5635     $self->{badtestcnt} ||= 0;
5636     $self->rematein('test',@_);
5637 }
5638 #-> sub CPAN::Bundle::install ;
5639 sub install {
5640   my $self = shift;
5641   $self->rematein('install',@_);
5642 }
5643 #-> sub CPAN::Bundle::clean ;
5644 sub clean   { shift->rematein('clean',@_); }
5645
5646 #-> sub CPAN::Bundle::uptodate ;
5647 sub uptodate {
5648     my($self) = @_;
5649     return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
5650     my $c;
5651     foreach $c ($self->contains) {
5652         my $obj = CPAN::Shell->expandany($c);
5653         return 0 unless $obj->uptodate;
5654     }
5655     return 1;
5656 }
5657
5658 #-> sub CPAN::Bundle::readme ;
5659 sub readme  {
5660     my($self) = @_;
5661     my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
5662 No File found for bundle } . $self->id . qq{\n}), return;
5663     $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
5664     $CPAN::META->instance('CPAN::Distribution',$file)->readme;
5665 }
5666
5667 package CPAN::Module;
5668 use strict;
5669
5670 # Accessors
5671 # sub CPAN::Module::userid
5672 sub userid {
5673     my $self = shift;
5674     my $ro = $self->ro;
5675     return unless $ro;
5676     return $ro->{userid} || $ro->{CPAN_USERID};
5677 }
5678 # sub CPAN::Module::description
5679 sub description { shift->ro->{description} }
5680
5681 sub undelay {
5682     my $self = shift;
5683     delete $self->{later};
5684     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5685         $dist->undelay;
5686     }
5687 }
5688
5689 # mark as dirty/clean
5690 #-> sub CPAN::Module::color_cmd_tmps ;
5691 sub color_cmd_tmps {
5692     my($self) = shift;
5693     my($depth) = shift || 0;
5694     my($color) = shift || 0;
5695     my($ancestors) = shift || [];
5696     # a module needs to recurse to its cpan_file
5697
5698     return if exists $self->{incommandcolor}
5699         && $self->{incommandcolor}==$color;
5700     return if $depth>=1 && $self->uptodate;
5701     if ($depth>=100){
5702         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
5703     }
5704     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5705
5706     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5707         $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5708     }
5709     if ($color==0) {
5710         delete $self->{badtestcnt};
5711     }
5712     $self->{incommandcolor} = $color;
5713 }
5714
5715 #-> sub CPAN::Module::as_glimpse ;
5716 sub as_glimpse {
5717     my($self) = @_;
5718     my(@m);
5719     my $class = ref($self);
5720     $class =~ s/^CPAN:://;
5721     my $color_on = "";
5722     my $color_off = "";
5723     if (
5724         $CPAN::Shell::COLOR_REGISTERED
5725         &&
5726         $CPAN::META->has_inst("Term::ANSIColor")
5727         &&
5728         $self->description
5729        ) {
5730         $color_on = Term::ANSIColor::color("green");
5731         $color_off = Term::ANSIColor::color("reset");
5732     }
5733     push @m, sprintf("%-15s %s%-15s%s (%s)\n",
5734                      $class,
5735                      $color_on,
5736                      $self->id,
5737                      $color_off,
5738                      $self->cpan_file);
5739     join "", @m;
5740 }
5741
5742 #-> sub CPAN::Module::as_string ;
5743 sub as_string {
5744     my($self) = @_;
5745     my(@m);
5746     CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
5747     my $class = ref($self);
5748     $class =~ s/^CPAN:://;
5749     local($^W) = 0;
5750     push @m, $class, " id = $self->{ID}\n";
5751     my $sprintf = "    %-12s %s\n";
5752     push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
5753         if $self->description;
5754     my $sprintf2 = "    %-12s %s (%s)\n";
5755     my($userid);
5756     $userid = $self->userid;
5757     if ( $userid ){
5758         my $author;
5759         if ($author = CPAN::Shell->expand('Author',$userid)) {
5760           my $email = "";
5761           my $m; # old perls
5762           if ($m = $author->email) {
5763             $email = " <$m>";
5764           }
5765           push @m, sprintf(
5766                            $sprintf2,
5767                            'CPAN_USERID',
5768                            $userid,
5769                            $author->fullname . $email
5770                           );
5771         }
5772     }
5773     push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
5774         if $self->cpan_version;
5775     if (my $cpan_file = $self->cpan_file){
5776         push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
5777         if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
5778             my $upload_date = $dist->upload_date;
5779             if ($upload_date) {
5780                 push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
5781             }
5782         }
5783     }
5784     my $sprintf3 = "    %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
5785     my(%statd,%stats,%statl,%stati);
5786     @statd{qw,? i c a b R M S,} = qw,unknown idea
5787         pre-alpha alpha beta released mature standard,;
5788     @stats{qw,? m d u n a,}       = qw,unknown mailing-list
5789         developer comp.lang.perl.* none abandoned,;
5790     @statl{qw,? p c + o h,}       = qw,unknown perl C C++ other hybrid,;
5791     @stati{qw,? f r O h,}         = qw,unknown functions
5792         references+ties object-oriented hybrid,;
5793     $statd{' '} = 'unknown';
5794     $stats{' '} = 'unknown';
5795     $statl{' '} = 'unknown';
5796     $stati{' '} = 'unknown';
5797     my $ro = $self->ro;
5798     push @m, sprintf(
5799                      $sprintf3,
5800                      'DSLI_STATUS',
5801                      $ro->{statd},
5802                      $ro->{stats},
5803                      $ro->{statl},
5804                      $ro->{stati},
5805                      $statd{$ro->{statd}},
5806                      $stats{$ro->{stats}},
5807                      $statl{$ro->{statl}},
5808                      $stati{$ro->{stati}}
5809                     ) if $ro->{statd};
5810     my $local_file = $self->inst_file;
5811     unless ($self->{MANPAGE}) {
5812         if ($local_file) {
5813             $self->{MANPAGE} = $self->manpage_headline($local_file);
5814         } else {
5815             # If we have already untarred it, we should look there
5816             my $dist = $CPAN::META->instance('CPAN::Distribution',
5817                                              $self->cpan_file);
5818             # warn "dist[$dist]";
5819             # mff=manifest file; mfh=manifest handle
5820             my($mff,$mfh);
5821             if (
5822                 $dist->{build_dir}
5823                 and
5824                 (-f  ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
5825                 and
5826                 $mfh = FileHandle->new($mff)
5827                ) {
5828                 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
5829                 my $lfre = $self->id; # local file RE
5830                 $lfre =~ s/::/./g;
5831                 $lfre .= "\\.pm\$";
5832                 my($lfl); # local file file
5833                 local $/ = "\n";
5834                 my(@mflines) = <$mfh>;
5835                 for (@mflines) {
5836                     s/^\s+//;
5837                     s/\s.*//s;
5838                 }
5839                 while (length($lfre)>5 and !$lfl) {
5840                     ($lfl) = grep /$lfre/, @mflines;
5841                     CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
5842                     $lfre =~ s/.+?\.//;
5843                 }
5844                 $lfl =~ s/\s.*//; # remove comments
5845                 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
5846                 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
5847                 # warn "lfl_abs[$lfl_abs]";
5848                 if (-f $lfl_abs) {
5849                     $self->{MANPAGE} = $self->manpage_headline($lfl_abs);
5850                 }
5851             }
5852         }
5853     }
5854     my($item);
5855     for $item (qw/MANPAGE/) {
5856         push @m, sprintf($sprintf, $item, $self->{$item})
5857             if exists $self->{$item};
5858     }
5859     for $item (qw/CONTAINS/) {
5860         push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
5861             if exists $self->{$item} && @{$self->{$item}};
5862     }
5863     push @m, sprintf($sprintf, 'INST_FILE',
5864                      $local_file || "(not installed)");
5865     push @m, sprintf($sprintf, 'INST_VERSION',
5866                      $self->inst_version) if $local_file;
5867     join "", @m, "\n";
5868 }
5869
5870 sub manpage_headline {
5871   my($self,$local_file) = @_;
5872   my(@local_file) = $local_file;
5873   $local_file =~ s/\.pm(?!\n)\Z/.pod/;
5874   push @local_file, $local_file;
5875   my(@result,$locf);
5876   for $locf (@local_file) {
5877     next unless -f $locf;
5878     my $fh = FileHandle->new($locf)
5879         or $Carp::Frontend->mydie("Couldn't open $locf: $!");
5880     my $inpod = 0;
5881     local $/ = "\n";
5882     while (<$fh>) {
5883       $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
5884           m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
5885       next unless $inpod;
5886       next if /^=/;
5887       next if /^\s+$/;
5888       chomp;
5889       push @result, $_;
5890     }
5891     close $fh;
5892     last if @result;
5893   }
5894   join " ", @result;
5895 }
5896
5897 #-> sub CPAN::Module::cpan_file ;
5898 # Note: also inherited by CPAN::Bundle
5899 sub cpan_file {
5900     my $self = shift;
5901     CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
5902     unless ($self->ro) {
5903         CPAN::Index->reload;
5904     }
5905     my $ro = $self->ro;
5906     if ($ro && defined $ro->{CPAN_FILE}){
5907         return $ro->{CPAN_FILE};
5908     } else {
5909         my $userid = $self->userid;
5910         if ( $userid ) {
5911             if ($CPAN::META->exists("CPAN::Author",$userid)) {
5912                 my $author = $CPAN::META->instance("CPAN::Author",
5913                                                    $userid);
5914                 my $fullname = $author->fullname;
5915                 my $email = $author->email;
5916                 unless (defined $fullname && defined $email) {
5917                     return sprintf("Contact Author %s",
5918                                    $userid,
5919                                   );
5920                 }
5921                 return "Contact Author $fullname <$email>";
5922             } else {
5923                 return "Contact Author $userid (Email address not available)";
5924             }
5925         } else {
5926             return "N/A";
5927         }
5928     }
5929 }
5930
5931 #-> sub CPAN::Module::cpan_version ;
5932 sub cpan_version {
5933     my $self = shift;
5934
5935     my $ro = $self->ro;
5936     unless ($ro) {
5937         # Can happen with modules that are not on CPAN
5938         $ro = {};
5939     }
5940     $ro->{CPAN_VERSION} = 'undef'
5941         unless defined $ro->{CPAN_VERSION};
5942     $ro->{CPAN_VERSION};
5943 }
5944
5945 #-> sub CPAN::Module::force ;
5946 sub force {
5947     my($self) = @_;
5948     $self->{'force_update'}++;
5949 }
5950
5951 sub notest {
5952     my($self) = @_;
5953     # warn "XDEBUG: set notest for Module";
5954     $self->{'notest'}++;
5955 }
5956
5957 #-> sub CPAN::Module::rematein ;
5958 sub rematein {
5959     my($self,$meth) = @_;
5960     $CPAN::Frontend->myprint(sprintf("Running %s for module %s\n",
5961                                      $meth,
5962                                      $self->id));
5963     my $cpan_file = $self->cpan_file;
5964     if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
5965       $CPAN::Frontend->mywarn(sprintf qq{
5966   The module %s isn\'t available on CPAN.
5967
5968   Either the module has not yet been uploaded to CPAN, or it is
5969   temporary unavailable. Please contact the author to find out
5970   more about the status. Try 'i %s'.
5971 },
5972                               $self->id,
5973                               $self->id,
5974                              );
5975       return;
5976     }
5977     my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
5978     $pack->called_for($self->id);
5979     $pack->force($meth) if exists $self->{'force_update'};
5980     $pack->notest($meth) if exists $self->{'notest'};
5981     eval {
5982         $pack->$meth();
5983     };
5984     my $err = $@;
5985     $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
5986     $pack->unnotest if $pack->can("unnotest") && exists $self->{'notest'};
5987     delete $self->{'force_update'};
5988     delete $self->{'notest'};
5989     if ($err) {
5990         die $err;
5991     }
5992 }
5993
5994 #-> sub CPAN::Module::perldoc ;
5995 sub perldoc { shift->rematein('perldoc') }
5996 #-> sub CPAN::Module::readme ;
5997 sub readme  { shift->rematein('readme') }
5998 #-> sub CPAN::Module::look ;
5999 sub look    { shift->rematein('look') }
6000 #-> sub CPAN::Module::cvs_import ;
6001 sub cvs_import { shift->rematein('cvs_import') }
6002 #-> sub CPAN::Module::get ;
6003 sub get     { shift->rematein('get',@_) }
6004 #-> sub CPAN::Module::make ;
6005 sub make    { shift->rematein('make') }
6006 #-> sub CPAN::Module::test ;
6007 sub test   {
6008     my $self = shift;
6009     $self->{badtestcnt} ||= 0;
6010     $self->rematein('test',@_);
6011 }
6012 #-> sub CPAN::Module::uptodate ;
6013 sub uptodate {
6014     my($self) = @_;
6015     my($latest) = $self->cpan_version;
6016     $latest ||= 0;
6017     my($inst_file) = $self->inst_file;
6018     my($have) = 0;
6019     if (defined $inst_file) {
6020         $have = $self->inst_version;
6021     }
6022     local($^W)=0;
6023     if ($inst_file
6024         &&
6025         ! CPAN::Version->vgt($latest, $have)
6026        ) {
6027         CPAN->debug("returning uptodate. inst_file[$inst_file] ".
6028                     "latest[$latest] have[$have]") if $CPAN::DEBUG;
6029         return 1;
6030     }
6031     return;
6032 }
6033 #-> sub CPAN::Module::install ;
6034 sub install {
6035     my($self) = @_;
6036     my($doit) = 0;
6037     if ($self->uptodate
6038         &&
6039         not exists $self->{'force_update'}
6040        ) {
6041         $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
6042                                          $self->id,
6043                                          $self->inst_version,
6044                                         ));
6045     } else {
6046         $doit = 1;
6047     }
6048     my $ro = $self->ro;
6049     if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
6050         $CPAN::Frontend->mywarn(qq{
6051 \n\n\n     ***WARNING***
6052      The module $self->{ID} has no active maintainer.\n\n\n
6053 });
6054         sleep 5;
6055     }
6056     $self->rematein('install') if $doit;
6057 }
6058 #-> sub CPAN::Module::clean ;
6059 sub clean  { shift->rematein('clean') }
6060
6061 #-> sub CPAN::Module::inst_file ;
6062 sub inst_file {
6063     my($self) = @_;
6064     my($dir,@packpath);
6065     @packpath = split /::/, $self->{ID};
6066     $packpath[-1] .= ".pm";
6067     foreach $dir (@INC) {
6068         my $pmfile = File::Spec->catfile($dir,@packpath);
6069         if (-f $pmfile){
6070             return $pmfile;
6071         }
6072     }
6073     return;
6074 }
6075
6076 #-> sub CPAN::Module::xs_file ;
6077 sub xs_file {
6078     my($self) = @_;
6079     my($dir,@packpath);
6080     @packpath = split /::/, $self->{ID};
6081     push @packpath, $packpath[-1];
6082     $packpath[-1] .= "." . $Config::Config{'dlext'};
6083     foreach $dir (@INC) {
6084         my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
6085         if (-f $xsfile){
6086             return $xsfile;
6087         }
6088     }
6089     return;
6090 }
6091
6092 #-> sub CPAN::Module::inst_version ;
6093 sub inst_version {
6094     my($self) = @_;
6095     my $parsefile = $self->inst_file or return;
6096     local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
6097     my $have;
6098
6099     # there was a bug in 5.6.0 that let lots of unini warnings out of
6100     # parse_version. Fixed shortly after 5.6.0 by PMQS. We can remove
6101     # the following workaround after 5.6.1 is out.
6102     local($SIG{__WARN__}) =  sub { my $w = shift;
6103                                    return if $w =~ /uninitialized/i;
6104                                    warn $w;
6105                                  };
6106
6107     $have = MM->parse_version($parsefile) || "undef";
6108     $have =~ s/^ //; # since the %vd hack these two lines here are needed
6109     $have =~ s/ $//; # trailing whitespace happens all the time
6110
6111     # My thoughts about why %vd processing should happen here
6112
6113     # Alt1 maintain it as string with leading v:
6114     # read index files     do nothing
6115     # compare it           use utility for compare
6116     # print it             do nothing
6117
6118     # Alt2 maintain it as what it is
6119     # read index files     convert
6120     # compare it           use utility because there's still a ">" vs "gt" issue
6121     # print it             use CPAN::Version for print
6122
6123     # Seems cleaner to hold it in memory as a string starting with a "v"
6124
6125     # If the author of this module made a mistake and wrote a quoted
6126     # "v1.13" instead of v1.13, we simply leave it at that with the
6127     # effect that *we* will treat it like a v-tring while the rest of
6128     # perl won't. Seems sensible when we consider that any action we
6129     # could take now would just add complexity.
6130
6131     $have = CPAN::Version->readable($have);
6132
6133     $have =~ s/\s*//g; # stringify to float around floating point issues
6134     $have; # no stringify needed, \s* above matches always
6135 }
6136
6137 package CPAN;
6138 use strict;
6139
6140 1;
6141
6142 __END__
6143
6144 =head1 NAME
6145
6146 CPAN - query, download and build perl modules from CPAN sites
6147
6148 =head1 SYNOPSIS
6149
6150 Interactive mode:
6151
6152   perl -MCPAN -e shell;
6153
6154 Batch mode:
6155
6156   use CPAN;
6157
6158   autobundle, clean, install, make, recompile, test
6159
6160 =head1 STATUS
6161
6162 This module will eventually be replaced by CPANPLUS. CPANPLUS is kind
6163 of a modern rewrite from ground up with greater extensibility and more
6164 features but no full compatibility. If you're new to CPAN.pm, you
6165 probably should investigate if CPANPLUS is the better choice for you.
6166 If you're already used to CPAN.pm you're welcome to continue using it,
6167 if you accept that its development is mostly (though not completely)
6168 stalled.
6169
6170 =head1 DESCRIPTION
6171
6172 The CPAN module is designed to automate the make and install of perl
6173 modules and extensions. It includes some primitive searching capabilities and
6174 knows how to use Net::FTP or LWP (or lynx or an external ftp client)
6175 to fetch the raw data from the net.
6176
6177 Modules are fetched from one or more of the mirrored CPAN
6178 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
6179 directory.
6180
6181 The CPAN module also supports the concept of named and versioned
6182 I<bundles> of modules. Bundles simplify the handling of sets of
6183 related modules. See Bundles below.
6184
6185 The package contains a session manager and a cache manager. There is
6186 no status retained between sessions. The session manager keeps track
6187 of what has been fetched, built and installed in the current
6188 session. The cache manager keeps track of the disk space occupied by
6189 the make processes and deletes excess space according to a simple FIFO
6190 mechanism.
6191
6192 For extended searching capabilities there's a plugin for CPAN available,
6193 L<C<CPAN::WAIT>|CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine
6194 that indexes all documents available in CPAN authors directories. If
6195 C<CPAN::WAIT> is installed on your system, the interactive shell of
6196 CPAN.pm will enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands
6197 which send queries to the WAIT server that has been configured for your
6198 installation.
6199
6200 All other methods provided are accessible in a programmer style and in an
6201 interactive shell style.
6202
6203 =head2 Interactive Mode
6204
6205 The interactive mode is entered by running
6206
6207     perl -MCPAN -e shell
6208
6209 which puts you into a readline interface. You will have the most fun if
6210 you install Term::ReadKey and Term::ReadLine to enjoy both history and
6211 command completion.
6212
6213 Once you are on the command line, type 'h' and the rest should be
6214 self-explanatory.
6215
6216 The function call C<shell> takes two optional arguments, one is the
6217 prompt, the second is the default initial command line (the latter
6218 only works if a real ReadLine interface module is installed).
6219
6220 The most common uses of the interactive modes are
6221
6222 =over 2
6223
6224 =item Searching for authors, bundles, distribution files and modules
6225
6226 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
6227 for each of the four categories and another, C<i> for any of the
6228 mentioned four. Each of the four entities is implemented as a class
6229 with slightly differing methods for displaying an object.
6230
6231 Arguments you pass to these commands are either strings exactly matching
6232 the identification string of an object or regular expressions that are
6233 then matched case-insensitively against various attributes of the
6234 objects. The parser recognizes a regular expression only if you
6235 enclose it between two slashes.
6236
6237 The principle is that the number of found objects influences how an
6238 item is displayed. If the search finds one item, the result is
6239 displayed with the rather verbose method C<as_string>, but if we find
6240 more than one, we display each object with the terse method
6241 <as_glimpse>.
6242
6243 =item make, test, install, clean  modules or distributions
6244
6245 These commands take any number of arguments and investigate what is
6246 necessary to perform the action. If the argument is a distribution
6247 file name (recognized by embedded slashes), it is processed. If it is
6248 a module, CPAN determines the distribution file in which this module
6249 is included and processes that, following any dependencies named in
6250 the module's META.yml or Makefile.PL (this behavior is controlled by
6251 I<prerequisites_policy>.)
6252
6253 Any C<make> or C<test> are run unconditionally. An
6254
6255   install <distribution_file>
6256
6257 also is run unconditionally. But for
6258
6259   install <module>
6260
6261 CPAN checks if an install is actually needed for it and prints
6262 I<module up to date> in the case that the distribution file containing
6263 the module doesn't need to be updated.
6264
6265 CPAN also keeps track of what it has done within the current session
6266 and doesn't try to build a package a second time regardless if it
6267 succeeded or not. The C<force> pragma may precede another command
6268 (currently: C<make>, C<test>, or C<install>) and executes the
6269 command from scratch.
6270
6271 Example:
6272
6273     cpan> install OpenGL
6274     OpenGL is up to date.
6275     cpan> force install OpenGL
6276     Running make
6277     OpenGL-0.4/
6278     OpenGL-0.4/COPYRIGHT
6279     [...]
6280
6281 The C<notest> pragma may be set to skip the test part in the build
6282 process.
6283
6284 Example:
6285
6286     cpan> notest install Tk
6287
6288 A C<clean> command results in a
6289
6290   make clean
6291
6292 being executed within the distribution file's working directory.
6293
6294 =item get, readme, perldoc, look module or distribution
6295
6296 C<get> downloads a distribution file without further action. C<readme>
6297 displays the README file of the associated distribution. C<Look> gets
6298 and untars (if not yet done) the distribution file, changes to the
6299 appropriate directory and opens a subshell process in that directory.
6300 C<perldoc> displays the pod documentation of the module in html or
6301 plain text format.
6302
6303 =item ls author
6304
6305 =item ls globbing_expresion
6306
6307 The first form lists all distribution files in and below an author's
6308 CPAN directory as they are stored in the CHECKUMS files distrbute on
6309 CPAN.
6310
6311 The second form allows to limit or expand the output with shell
6312 globbing as in the following examples:
6313
6314           ls JV/make*
6315           ls GSAR/*make*
6316           ls */*make*
6317
6318 The last example is very slow and outputs extra progress indicators
6319 that break the alignment of the result.
6320
6321 =item Signals
6322
6323 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
6324 in the cpan-shell it is intended that you can press C<^C> anytime and
6325 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
6326 to clean up and leave the shell loop. You can emulate the effect of a
6327 SIGTERM by sending two consecutive SIGINTs, which usually means by
6328 pressing C<^C> twice.
6329
6330 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
6331 SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl
6332 Build.PL> subprocess.
6333
6334 =back
6335
6336 =head2 CPAN::Shell
6337
6338 The commands that are available in the shell interface are methods in
6339 the package CPAN::Shell. If you enter the shell command, all your
6340 input is split by the Text::ParseWords::shellwords() routine which
6341 acts like most shells do. The first word is being interpreted as the
6342 method to be called and the rest of the words are treated as arguments
6343 to this method. Continuation lines are supported if a line ends with a
6344 literal backslash.
6345
6346 =head2 autobundle
6347
6348 C<autobundle> writes a bundle file into the
6349 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
6350 a list of all modules that are both available from CPAN and currently
6351 installed within @INC. The name of the bundle file is based on the
6352 current date and a counter.
6353
6354 =head2 recompile
6355
6356 recompile() is a very special command in that it takes no argument and
6357 runs the make/test/install cycle with brute force over all installed
6358 dynamically loadable extensions (aka XS modules) with 'force' in
6359 effect. The primary purpose of this command is to finish a network
6360 installation. Imagine, you have a common source tree for two different
6361 architectures. You decide to do a completely independent fresh
6362 installation. You start on one architecture with the help of a Bundle
6363 file produced earlier. CPAN installs the whole Bundle for you, but
6364 when you try to repeat the job on the second architecture, CPAN
6365 responds with a C<"Foo up to date"> message for all modules. So you
6366 invoke CPAN's recompile on the second architecture and you're done.
6367
6368 Another popular use for C<recompile> is to act as a rescue in case your
6369 perl breaks binary compatibility. If one of the modules that CPAN uses
6370 is in turn depending on binary compatibility (so you cannot run CPAN
6371 commands), then you should try the CPAN::Nox module for recovery.
6372
6373 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
6374
6375 Although it may be considered internal, the class hierarchy does matter
6376 for both users and programmer. CPAN.pm deals with above mentioned four
6377 classes, and all those classes share a set of methods. A classical
6378 single polymorphism is in effect. A metaclass object registers all
6379 objects of all kinds and indexes them with a string. The strings
6380 referencing objects have a separated namespace (well, not completely
6381 separated):
6382
6383          Namespace                         Class
6384
6385    words containing a "/" (slash)      Distribution
6386     words starting with Bundle::          Bundle
6387           everything else            Module or Author
6388
6389 Modules know their associated Distribution objects. They always refer
6390 to the most recent official release. Developers may mark their releases
6391 as unstable development versions (by inserting an underbar into the
6392 module version number which will also be reflected in the distribution
6393 name when you run 'make dist'), so the really hottest and newest
6394 distribution is not always the default.  If a module Foo circulates
6395 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
6396 way to install version 1.23 by saying
6397
6398     install Foo
6399
6400 This would install the complete distribution file (say
6401 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
6402 like to install version 1.23_90, you need to know where the
6403 distribution file resides on CPAN relative to the authors/id/
6404 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
6405 so you would have to say
6406
6407     install BAR/Foo-1.23_90.tar.gz
6408
6409 The first example will be driven by an object of the class
6410 CPAN::Module, the second by an object of class CPAN::Distribution.
6411
6412 =head2 Programmer's interface
6413
6414 If you do not enter the shell, the available shell commands are both
6415 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
6416 functions in the calling package (C<install(...)>).
6417
6418 There's currently only one class that has a stable interface -
6419 CPAN::Shell. All commands that are available in the CPAN shell are
6420 methods of the class CPAN::Shell. Each of the commands that produce
6421 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
6422 the IDs of all modules within the list.
6423
6424 =over 2
6425
6426 =item expand($type,@things)
6427
6428 The IDs of all objects available within a program are strings that can
6429 be expanded to the corresponding real objects with the
6430 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
6431 list of CPAN::Module objects according to the C<@things> arguments
6432 given. In scalar context it only returns the first element of the
6433 list.
6434
6435 =item expandany(@things)
6436
6437 Like expand, but returns objects of the appropriate type, i.e.
6438 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
6439 CPAN::Distribution objects fro distributions.
6440
6441 =item Programming Examples
6442
6443 This enables the programmer to do operations that combine
6444 functionalities that are available in the shell.
6445
6446     # install everything that is outdated on my disk:
6447     perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
6448
6449     # install my favorite programs if necessary:
6450     for $mod (qw(Net::FTP Digest::SHA Data::Dumper)){
6451         my $obj = CPAN::Shell->expand('Module',$mod);
6452         $obj->install;
6453     }
6454
6455     # list all modules on my disk that have no VERSION number
6456     for $mod (CPAN::Shell->expand("Module","/./")){
6457         next unless $mod->inst_file;
6458         # MakeMaker convention for undefined $VERSION:
6459         next unless $mod->inst_version eq "undef";
6460         print "No VERSION in ", $mod->id, "\n";
6461     }
6462
6463     # find out which distribution on CPAN contains a module:
6464     print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
6465
6466 Or if you want to write a cronjob to watch The CPAN, you could list
6467 all modules that need updating. First a quick and dirty way:
6468
6469     perl -e 'use CPAN; CPAN::Shell->r;'
6470
6471 If you don't want to get any output in the case that all modules are
6472 up to date, you can parse the output of above command for the regular
6473 expression //modules are up to date// and decide to mail the output
6474 only if it doesn't match. Ick?
6475
6476 If you prefer to do it more in a programmer style in one single
6477 process, maybe something like this suits you better:
6478
6479   # list all modules on my disk that have newer versions on CPAN
6480   for $mod (CPAN::Shell->expand("Module","/./")){
6481     next unless $mod->inst_file;
6482     next if $mod->uptodate;
6483     printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
6484         $mod->id, $mod->inst_version, $mod->cpan_version;
6485   }
6486
6487 If that gives you too much output every day, you maybe only want to
6488 watch for three modules. You can write
6489
6490   for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
6491
6492 as the first line instead. Or you can combine some of the above
6493 tricks:
6494
6495   # watch only for a new mod_perl module
6496   $mod = CPAN::Shell->expand("Module","mod_perl");
6497   exit if $mod->uptodate;
6498   # new mod_perl arrived, let me know all update recommendations
6499   CPAN::Shell->r;
6500
6501 =back
6502
6503 =head2 Methods in the other Classes
6504
6505 The programming interface for the classes CPAN::Module,
6506 CPAN::Distribution, CPAN::Bundle, and CPAN::Author is still considered
6507 beta and partially even alpha. In the following paragraphs only those
6508 methods are documented that have proven useful over a longer time and
6509 thus are unlikely to change.
6510
6511 =over 4
6512
6513 =item CPAN::Author::as_glimpse()
6514
6515 Returns a one-line description of the author
6516
6517 =item CPAN::Author::as_string()
6518
6519 Returns a multi-line description of the author
6520
6521 =item CPAN::Author::email()
6522
6523 Returns the author's email address
6524
6525 =item CPAN::Author::fullname()
6526
6527 Returns the author's name
6528
6529 =item CPAN::Author::name()
6530
6531 An alias for fullname
6532
6533 =item CPAN::Bundle::as_glimpse()
6534
6535 Returns a one-line description of the bundle
6536
6537 =item CPAN::Bundle::as_string()
6538
6539 Returns a multi-line description of the bundle
6540
6541 =item CPAN::Bundle::clean()
6542
6543 Recursively runs the C<clean> method on all items contained in the bundle.
6544
6545 =item CPAN::Bundle::contains()
6546
6547 Returns a list of objects' IDs contained in a bundle. The associated
6548 objects may be bundles, modules or distributions.
6549
6550 =item CPAN::Bundle::force($method,@args)
6551
6552 Forces CPAN to perform a task that normally would have failed. Force
6553 takes as arguments a method name to be called and any number of
6554 additional arguments that should be passed to the called method. The
6555 internals of the object get the needed changes so that CPAN.pm does
6556 not refuse to take the action. The C<force> is passed recursively to
6557 all contained objects.
6558
6559 =item CPAN::Bundle::get()
6560
6561 Recursively runs the C<get> method on all items contained in the bundle
6562
6563 =item CPAN::Bundle::inst_file()
6564
6565 Returns the highest installed version of the bundle in either @INC or
6566 C<$CPAN::Config->{cpan_home}>. Note that this is different from
6567 CPAN::Module::inst_file.
6568
6569 =item CPAN::Bundle::inst_version()
6570
6571 Like CPAN::Bundle::inst_file, but returns the $VERSION
6572
6573 =item CPAN::Bundle::uptodate()
6574
6575 Returns 1 if the bundle itself and all its members are uptodate.
6576
6577 =item CPAN::Bundle::install()
6578
6579 Recursively runs the C<install> method on all items contained in the bundle
6580
6581 =item CPAN::Bundle::make()
6582
6583 Recursively runs the C<make> method on all items contained in the bundle
6584
6585 =item CPAN::Bundle::readme()
6586
6587 Recursively runs the C<readme> method on all items contained in the bundle
6588
6589 =item CPAN::Bundle::test()
6590
6591 Recursively runs the C<test> method on all items contained in the bundle
6592
6593 =item CPAN::Distribution::as_glimpse()
6594
6595 Returns a one-line description of the distribution
6596
6597 =item CPAN::Distribution::as_string()
6598
6599 Returns a multi-line description of the distribution
6600
6601 =item CPAN::Distribution::clean()
6602
6603 Changes to the directory where the distribution has been unpacked and
6604 runs C<make clean> there.
6605
6606 =item CPAN::Distribution::containsmods()
6607
6608 Returns a list of IDs of modules contained in a distribution file.
6609 Only works for distributions listed in the 02packages.details.txt.gz
6610 file. This typically means that only the most recent version of a
6611 distribution is covered.
6612
6613 =item CPAN::Distribution::cvs_import()
6614
6615 Changes to the directory where the distribution has been unpacked and
6616 runs something like
6617
6618     cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
6619
6620 there.
6621
6622 =item CPAN::Distribution::dir()
6623
6624 Returns the directory into which this distribution has been unpacked.
6625
6626 =item CPAN::Distribution::force($method,@args)
6627
6628 Forces CPAN to perform a task that normally would have failed. Force
6629 takes as arguments a method name to be called and any number of
6630 additional arguments that should be passed to the called method. The
6631 internals of the object get the needed changes so that CPAN.pm does
6632 not refuse to take the action.
6633
6634 =item CPAN::Distribution::get()
6635
6636 Downloads the distribution from CPAN and unpacks it. Does nothing if
6637 the distribution has already been downloaded and unpacked within the
6638 current session.
6639
6640 =item CPAN::Distribution::install()
6641
6642 Changes to the directory where the distribution has been unpacked and
6643 runs the external command C<make install> there. If C<make> has not
6644 yet been run, it will be run first. A C<make test> will be issued in
6645 any case and if this fails, the install will be canceled. The
6646 cancellation can be avoided by letting C<force> run the C<install> for
6647 you.
6648
6649 =item CPAN::Distribution::isa_perl()
6650
6651 Returns 1 if this distribution file seems to be a perl distribution.
6652 Normally this is derived from the file name only, but the index from
6653 CPAN can contain a hint to achieve a return value of true for other
6654 filenames too.
6655
6656 =item CPAN::Distribution::look()
6657
6658 Changes to the directory where the distribution has been unpacked and
6659 opens a subshell there. Exiting the subshell returns.
6660
6661 =item CPAN::Distribution::make()
6662
6663 First runs the C<get> method to make sure the distribution is
6664 downloaded and unpacked. Changes to the directory where the
6665 distribution has been unpacked and runs the external commands C<perl
6666 Makefile.PL> or C<perl Build.PL> and C<make> there.
6667
6668 =item CPAN::Distribution::prereq_pm()
6669
6670 Returns the hash reference that has been announced by a distribution
6671 as the C<requires> element of the META.yml or the C<PREREQ_PM> hash in
6672 the C<Makefile.PL>. Note: works only after an attempt has been made to
6673 C<make> the distribution. Returns undef otherwise.
6674
6675 =item CPAN::Distribution::readme()
6676
6677 Downloads the README file associated with a distribution and runs it
6678 through the pager specified in C<$CPAN::Config->{pager}>.
6679
6680 =item CPAN::Distribution::perldoc()
6681
6682 Downloads the pod documentation of the file associated with a
6683 distribution (in html format) and runs it through the external
6684 command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
6685 isn't available, it converts it to plain text with external
6686 command html2text and runs it through the pager specified
6687 in C<$CPAN::Config->{pager}>
6688
6689 =item CPAN::Distribution::test()
6690
6691 Changes to the directory where the distribution has been unpacked and
6692 runs C<make test> there.
6693
6694 =item CPAN::Distribution::uptodate()
6695
6696 Returns 1 if all the modules contained in the distribution are
6697 uptodate. Relies on containsmods.
6698
6699 =item CPAN::Index::force_reload()
6700
6701 Forces a reload of all indices.
6702
6703 =item CPAN::Index::reload()
6704
6705 Reloads all indices if they have not been read for more than
6706 C<$CPAN::Config->{index_expire}> days.
6707
6708 =item CPAN::InfoObj::dump()
6709
6710 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
6711 inherit this method. It prints the data structure associated with an
6712 object. Useful for debugging. Note: the data structure is considered
6713 internal and thus subject to change without notice.
6714
6715 =item CPAN::Module::as_glimpse()
6716
6717 Returns a one-line description of the module
6718
6719 =item CPAN::Module::as_string()
6720
6721 Returns a multi-line description of the module
6722
6723 =item CPAN::Module::clean()
6724
6725 Runs a clean on the distribution associated with this module.
6726
6727 =item CPAN::Module::cpan_file()
6728
6729 Returns the filename on CPAN that is associated with the module.
6730
6731 =item CPAN::Module::cpan_version()
6732
6733 Returns the latest version of this module available on CPAN.
6734
6735 =item CPAN::Module::cvs_import()
6736
6737 Runs a cvs_import on the distribution associated with this module.
6738
6739 =item CPAN::Module::description()
6740
6741 Returns a 44 character description of this module. Only available for
6742 modules listed in The Module List (CPAN/modules/00modlist.long.html
6743 or 00modlist.long.txt.gz)
6744
6745 =item CPAN::Module::force($method,@args)
6746
6747 Forces CPAN to perform a task that normally would have failed. Force
6748 takes as arguments a method name to be called and any number of
6749 additional arguments that should be passed to the called method. The
6750 internals of the object get the needed changes so that CPAN.pm does
6751 not refuse to take the action.
6752
6753 =item CPAN::Module::get()
6754
6755 Runs a get on the distribution associated with this module.
6756
6757 =item CPAN::Module::inst_file()
6758
6759 Returns the filename of the module found in @INC. The first file found
6760 is reported just like perl itself stops searching @INC when it finds a
6761 module.
6762
6763 =item CPAN::Module::inst_version()
6764
6765 Returns the version number of the module in readable format.
6766
6767 =item CPAN::Module::install()
6768
6769 Runs an C<install> on the distribution associated with this module.
6770
6771 =item CPAN::Module::look()
6772
6773 Changes to the directory where the distribution associated with this
6774 module has been unpacked and opens a subshell there. Exiting the
6775 subshell returns.
6776
6777 =item CPAN::Module::make()
6778
6779 Runs a C<make> on the distribution associated with this module.
6780
6781 =item CPAN::Module::manpage_headline()
6782
6783 If module is installed, peeks into the module's manpage, reads the
6784 headline and returns it. Moreover, if the module has been downloaded
6785 within this session, does the equivalent on the downloaded module even
6786 if it is not installed.
6787
6788 =item CPAN::Module::readme()
6789
6790 Runs a C<readme> on the distribution associated with this module.
6791
6792 =item CPAN::Module::perldoc()
6793
6794 Runs a C<perldoc> on this module.
6795
6796 =item CPAN::Module::test()
6797
6798 Runs a C<test> on the distribution associated with this module.
6799
6800 =item CPAN::Module::uptodate()
6801
6802 Returns 1 if the module is installed and up-to-date.
6803
6804 =item CPAN::Module::userid()
6805
6806 Returns the author's ID of the module.
6807
6808 =back
6809
6810 =head2 Cache Manager
6811
6812 Currently the cache manager only keeps track of the build directory
6813 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
6814 deletes complete directories below C<build_dir> as soon as the size of
6815 all directories there gets bigger than $CPAN::Config->{build_cache}
6816 (in MB). The contents of this cache may be used for later
6817 re-installations that you intend to do manually, but will never be
6818 trusted by CPAN itself. This is due to the fact that the user might
6819 use these directories for building modules on different architectures.
6820
6821 There is another directory ($CPAN::Config->{keep_source_where}) where
6822 the original distribution files are kept. This directory is not
6823 covered by the cache manager and must be controlled by the user. If
6824 you choose to have the same directory as build_dir and as
6825 keep_source_where directory, then your sources will be deleted with
6826 the same fifo mechanism.
6827
6828 =head2 Bundles
6829
6830 A bundle is just a perl module in the namespace Bundle:: that does not
6831 define any functions or methods. It usually only contains documentation.
6832
6833 It starts like a perl module with a package declaration and a $VERSION
6834 variable. After that the pod section looks like any other pod with the
6835 only difference being that I<one special pod section> exists starting with
6836 (verbatim):
6837
6838         =head1 CONTENTS
6839
6840 In this pod section each line obeys the format
6841
6842         Module_Name [Version_String] [- optional text]
6843
6844 The only required part is the first field, the name of a module
6845 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
6846 of the line is optional. The comment part is delimited by a dash just
6847 as in the man page header.
6848
6849 The distribution of a bundle should follow the same convention as
6850 other distributions.
6851
6852 Bundles are treated specially in the CPAN package. If you say 'install
6853 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
6854 the modules in the CONTENTS section of the pod. You can install your
6855 own Bundles locally by placing a conformant Bundle file somewhere into
6856 your @INC path. The autobundle() command which is available in the
6857 shell interface does that for you by including all currently installed
6858 modules in a snapshot bundle file.
6859
6860 =head2 Prerequisites
6861
6862 If you have a local mirror of CPAN and can access all files with
6863 "file:" URLs, then you only need a perl better than perl5.003 to run
6864 this module. Otherwise Net::FTP is strongly recommended. LWP may be
6865 required for non-UNIX systems or if your nearest CPAN site is
6866 associated with a URL that is not C<ftp:>.
6867
6868 If you have neither Net::FTP nor LWP, there is a fallback mechanism
6869 implemented for an external ftp command or for an external lynx
6870 command.
6871
6872 =head2 Finding packages and VERSION
6873
6874 This module presumes that all packages on CPAN
6875
6876 =over 2
6877
6878 =item *
6879
6880 declare their $VERSION variable in an easy to parse manner. This
6881 prerequisite can hardly be relaxed because it consumes far too much
6882 memory to load all packages into the running program just to determine
6883 the $VERSION variable. Currently all programs that are dealing with
6884 version use something like this
6885
6886     perl -MExtUtils::MakeMaker -le \
6887         'print MM->parse_version(shift)' filename
6888
6889 If you are author of a package and wonder if your $VERSION can be
6890 parsed, please try the above method.
6891
6892 =item *
6893
6894 come as compressed or gzipped tarfiles or as zip files and contain a
6895 C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
6896 without much enthusiasm).
6897
6898 =back
6899
6900 =head2 Debugging
6901
6902 The debugging of this module is a bit complex, because we have
6903 interferences of the software producing the indices on CPAN, of the
6904 mirroring process on CPAN, of packaging, of configuration, of
6905 synchronicity, and of bugs within CPAN.pm.
6906
6907 For code debugging in interactive mode you can try "o debug" which
6908 will list options for debugging the various parts of the code. You
6909 should know that "o debug" has built-in completion support.
6910
6911 For data debugging there is the C<dump> command which takes the same
6912 arguments as make/test/install and outputs the object's Data::Dumper
6913 dump.
6914
6915 =head2 Floppy, Zip, Offline Mode
6916
6917 CPAN.pm works nicely without network too. If you maintain machines
6918 that are not networked at all, you should consider working with file:
6919 URLs. Of course, you have to collect your modules somewhere first. So
6920 you might use CPAN.pm to put together all you need on a networked
6921 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
6922 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
6923 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
6924 with this floppy. See also below the paragraph about CD-ROM support.
6925
6926 =head1 CONFIGURATION
6927
6928 When the CPAN module is used for the first time, a configuration
6929 dialog tries to determine a couple of site specific options. The
6930 result of the dialog is stored in a hash reference C< $CPAN::Config >
6931 in a file CPAN/Config.pm.
6932
6933 The default values defined in the CPAN/Config.pm file can be
6934 overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
6935 best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
6936 added to the search path of the CPAN module before the use() or
6937 require() statements.
6938
6939 The configuration dialog can be started any time later again by
6940 issuing the command C< o conf init > in the CPAN shell.
6941
6942 Currently the following keys in the hash reference $CPAN::Config are
6943 defined:
6944
6945   build_cache        size of cache for directories to build modules
6946   build_dir          locally accessible directory to build modules
6947   index_expire       after this many days refetch index files
6948   cache_metadata     use serializer to cache metadata
6949   cpan_home          local directory reserved for this package
6950   dontload_hash      anonymous hash: modules in the keys will not be
6951                      loaded by the CPAN::has_inst() routine
6952   gzip               location of external program gzip
6953   histfile           file to maintain history between sessions
6954   histsize           maximum number of lines to keep in histfile
6955   inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
6956                      after this many seconds inactivity. Set to 0 to
6957                      never break.
6958   inhibit_startup_message
6959                      if true, does not print the startup message
6960   keep_source_where  directory in which to keep the source (if we do)
6961   make               location of external make program
6962   make_arg           arguments that should always be passed to 'make'
6963   make_install_make_command
6964                      the make command for running 'make install', for
6965                      example 'sudo make'
6966   make_install_arg   same as make_arg for 'make install'
6967   makepl_arg         arguments passed to 'perl Makefile.PL'
6968   mbuild_arg         arguments passed to './Build'
6969   mbuild_install_arg arguments passed to './Build install'
6970   mbuild_install_build_command
6971                      command to use instead of './Build' when we are
6972                      in the install stage, for example 'sudo ./Build'
6973   mbuildpl_arg       arguments passed to 'perl Build.PL'
6974   pager              location of external program more (or any pager)
6975   prefer_installer   legal values are MB and EUMM: if a module
6976                      comes with both a Makefile.PL and a Build.PL, use
6977                      the former (EUMM) or the latter (MB)
6978   prerequisites_policy
6979                      what to do if you are missing module prerequisites
6980                      ('follow' automatically, 'ask' me, or 'ignore')
6981   proxy_user         username for accessing an authenticating proxy
6982   proxy_pass         password for accessing an authenticating proxy
6983   scan_cache         controls scanning of cache ('atstart' or 'never')
6984   tar                location of external program tar
6985   term_is_latin      if true internal UTF-8 is translated to ISO-8859-1
6986                      (and nonsense for characters outside latin range)
6987   unzip              location of external program unzip
6988   urllist            arrayref to nearby CPAN sites (or equivalent locations)
6989   wait_list          arrayref to a wait server to try (See CPAN::WAIT)
6990   ftp_proxy,      }  the three usual variables for configuring
6991     http_proxy,   }  proxy requests. Both as CPAN::Config variables
6992     no_proxy      }  and as environment variables configurable.
6993
6994 You can set and query each of these options interactively in the cpan
6995 shell with the command set defined within the C<o conf> command:
6996
6997 =over 2
6998
6999 =item C<o conf E<lt>scalar optionE<gt>>
7000
7001 prints the current value of the I<scalar option>
7002
7003 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
7004
7005 Sets the value of the I<scalar option> to I<value>
7006
7007 =item C<o conf E<lt>list optionE<gt>>
7008
7009 prints the current value of the I<list option> in MakeMaker's
7010 neatvalue format.
7011
7012 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
7013
7014 shifts or pops the array in the I<list option> variable
7015
7016 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
7017
7018 works like the corresponding perl commands.
7019
7020 =back
7021
7022 =head2 Note on urllist parameter's format
7023
7024 urllist parameters are URLs according to RFC 1738. We do a little
7025 guessing if your URL is not compliant, but if you have problems with
7026 file URLs, please try the correct format. Either:
7027
7028     file://localhost/whatever/ftp/pub/CPAN/
7029
7030 or
7031
7032     file:///home/ftp/pub/CPAN/
7033
7034 =head2 urllist parameter has CD-ROM support
7035
7036 The C<urllist> parameter of the configuration table contains a list of
7037 URLs that are to be used for downloading. If the list contains any
7038 C<file> URLs, CPAN always tries to get files from there first. This
7039 feature is disabled for index files. So the recommendation for the
7040 owner of a CD-ROM with CPAN contents is: include your local, possibly
7041 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
7042
7043   o conf urllist push file://localhost/CDROM/CPAN
7044
7045 CPAN.pm will then fetch the index files from one of the CPAN sites
7046 that come at the beginning of urllist. It will later check for each
7047 module if there is a local copy of the most recent version.
7048
7049 Another peculiarity of urllist is that the site that we could
7050 successfully fetch the last file from automatically gets a preference
7051 token and is tried as the first site for the next request. So if you
7052 add a new site at runtime it may happen that the previously preferred
7053 site will be tried another time. This means that if you want to disallow
7054 a site for the next transfer, it must be explicitly removed from
7055 urllist.
7056
7057 =head1 SECURITY
7058
7059 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
7060 install foreign, unmasked, unsigned code on your machine. We compare
7061 to a checksum that comes from the net just as the distribution file
7062 itself. But we try to make it easy to add security on demand:
7063
7064 =head2 Cryptographically signed modules
7065
7066 Since release 1.77 CPAN.pm has been able to verify cryptographically
7067 signed module distributions using Module::Signature.  The CPAN modules
7068 can be signed by their authors, thus giving more security.  The simple
7069 unsigned MD5 checksums that were used before by CPAN protect mainly
7070 against accidental file corruption.
7071
7072 You will need to have Module::Signature installed, which in turn
7073 requires that you have at least one of Crypt::OpenPGP module or the
7074 command-line F<gpg> tool installed.
7075
7076 You will also need to be able to connect over the Internet to the public
7077 keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
7078
7079 =head1 EXPORT
7080
7081 Most functions in package CPAN are exported per default. The reason
7082 for this is that the primary use is intended for the cpan shell or for
7083 one-liners.
7084
7085 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
7086
7087 Populating a freshly installed perl with my favorite modules is pretty
7088 easy if you maintain a private bundle definition file. To get a useful
7089 blueprint of a bundle definition file, the command autobundle can be used
7090 on the CPAN shell command line. This command writes a bundle definition
7091 file for all modules that are installed for the currently running perl
7092 interpreter. It's recommended to run this command only once and from then
7093 on maintain the file manually under a private name, say
7094 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
7095
7096     cpan> install Bundle::my_bundle
7097
7098 then answer a few questions and then go out for a coffee.
7099
7100 Maintaining a bundle definition file means keeping track of two
7101 things: dependencies and interactivity. CPAN.pm sometimes fails on
7102 calculating dependencies because not all modules define all MakeMaker
7103 attributes correctly, so a bundle definition file should specify
7104 prerequisites as early as possible. On the other hand, it's a bit
7105 annoying that many distributions need some interactive configuring. So
7106 what I try to accomplish in my private bundle file is to have the
7107 packages that need to be configured early in the file and the gentle
7108 ones later, so I can go out after a few minutes and leave CPAN.pm
7109 untended.
7110
7111 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
7112
7113 Thanks to Graham Barr for contributing the following paragraphs about
7114 the interaction between perl, and various firewall configurations. For
7115 further information on firewalls, it is recommended to consult the
7116 documentation that comes with the ncftp program. If you are unable to
7117 go through the firewall with a simple Perl setup, it is very likely
7118 that you can configure ncftp so that it works for your firewall.
7119
7120 =head2 Three basic types of firewalls
7121
7122 Firewalls can be categorized into three basic types.
7123
7124 =over 4
7125
7126 =item http firewall
7127
7128 This is where the firewall machine runs a web server and to access the
7129 outside world you must do it via the web server. If you set environment
7130 variables like http_proxy or ftp_proxy to a values beginning with http://
7131 or in your web browser you have to set proxy information then you know
7132 you are running an http firewall.
7133
7134 To access servers outside these types of firewalls with perl (even for
7135 ftp) you will need to use LWP.
7136
7137 =item ftp firewall
7138
7139 This where the firewall machine runs an ftp server. This kind of
7140 firewall will only let you access ftp servers outside the firewall.
7141 This is usually done by connecting to the firewall with ftp, then
7142 entering a username like "user@outside.host.com"
7143
7144 To access servers outside these type of firewalls with perl you
7145 will need to use Net::FTP.
7146
7147 =item One way visibility
7148
7149 I say one way visibility as these firewalls try to make themselves look
7150 invisible to the users inside the firewall. An FTP data connection is
7151 normally created by sending the remote server your IP address and then
7152 listening for the connection. But the remote server will not be able to
7153 connect to you because of the firewall. So for these types of firewall
7154 FTP connections need to be done in a passive mode.
7155
7156 There are two that I can think off.
7157
7158 =over 4
7159
7160 =item SOCKS
7161
7162 If you are using a SOCKS firewall you will need to compile perl and link
7163 it with the SOCKS library, this is what is normally called a 'socksified'
7164 perl. With this executable you will be able to connect to servers outside
7165 the firewall as if it is not there.
7166
7167 =item IP Masquerade
7168
7169 This is the firewall implemented in the Linux kernel, it allows you to
7170 hide a complete network behind one IP address. With this firewall no
7171 special compiling is needed as you can access hosts directly.
7172
7173 For accessing ftp servers behind such firewalls you may need to set
7174 the environment variable C<FTP_PASSIVE> to a true value, e.g.
7175
7176     env FTP_PASSIVE=1 perl -MCPAN -eshell
7177
7178 or
7179
7180     perl -MCPAN -e '$ENV{FTP_PASSIVE} = 1; shell'
7181
7182
7183 =back
7184
7185 =back
7186
7187 =head2 Configuring lynx or ncftp for going through a firewall
7188
7189 If you can go through your firewall with e.g. lynx, presumably with a
7190 command such as
7191
7192     /usr/local/bin/lynx -pscott:tiger
7193
7194 then you would configure CPAN.pm with the command
7195
7196     o conf lynx "/usr/local/bin/lynx -pscott:tiger"
7197
7198 That's all. Similarly for ncftp or ftp, you would configure something
7199 like
7200
7201     o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
7202
7203 Your mileage may vary...
7204
7205 =head1 FAQ
7206
7207 =over 4
7208
7209 =item 1)
7210
7211 I installed a new version of module X but CPAN keeps saying,
7212 I have the old version installed
7213
7214 Most probably you B<do> have the old version installed. This can
7215 happen if a module installs itself into a different directory in the
7216 @INC path than it was previously installed. This is not really a
7217 CPAN.pm problem, you would have the same problem when installing the
7218 module manually. The easiest way to prevent this behaviour is to add
7219 the argument C<UNINST=1> to the C<make install> call, and that is why
7220 many people add this argument permanently by configuring
7221
7222   o conf make_install_arg UNINST=1
7223
7224 =item 2)
7225
7226 So why is UNINST=1 not the default?
7227
7228 Because there are people who have their precise expectations about who
7229 may install where in the @INC path and who uses which @INC array. In
7230 fine tuned environments C<UNINST=1> can cause damage.
7231
7232 =item 3)
7233
7234 I want to clean up my mess, and install a new perl along with
7235 all modules I have. How do I go about it?
7236
7237 Run the autobundle command for your old perl and optionally rename the
7238 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
7239 with the Configure option prefix, e.g.
7240
7241     ./Configure -Dprefix=/usr/local/perl-5.6.78.9
7242
7243 Install the bundle file you produced in the first step with something like
7244
7245     cpan> install Bundle::mybundle
7246
7247 and you're done.
7248
7249 =item 4)
7250
7251 When I install bundles or multiple modules with one command
7252 there is too much output to keep track of.
7253
7254 You may want to configure something like
7255
7256   o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
7257   o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
7258
7259 so that STDOUT is captured in a file for later inspection.
7260
7261
7262 =item 5)
7263
7264 I am not root, how can I install a module in a personal directory?
7265
7266 First of all, you will want to use your own configuration, not the one
7267 that your root user installed. The following command sequence is a
7268 possible approach:
7269
7270     % mkdir -p $HOME/.cpan/CPAN
7271     % echo '$CPAN::Config={ };' > $HOME/.cpan/CPAN/MyConfig.pm
7272     % cpan
7273     [...answer all questions...]
7274
7275 You will most probably like something like this:
7276
7277   o conf makepl_arg "LIB=~/myperl/lib \
7278                     INSTALLMAN1DIR=~/myperl/man/man1 \
7279                     INSTALLMAN3DIR=~/myperl/man/man3"
7280
7281 You can make this setting permanent like all C<o conf> settings with
7282 C<o conf commit>.
7283
7284 You will have to add ~/myperl/man to the MANPATH environment variable
7285 and also tell your perl programs to look into ~/myperl/lib, e.g. by
7286 including
7287
7288   use lib "$ENV{HOME}/myperl/lib";
7289
7290 or setting the PERL5LIB environment variable.
7291
7292 Another thing you should bear in mind is that the UNINST parameter
7293 should never be set if you are not root.
7294
7295 =item 6)
7296
7297 How to get a package, unwrap it, and make a change before building it?
7298
7299   look Sybase::Sybperl
7300
7301 =item 7)
7302
7303 I installed a Bundle and had a couple of fails. When I
7304 retried, everything resolved nicely. Can this be fixed to work
7305 on first try?
7306
7307 The reason for this is that CPAN does not know the dependencies of all
7308 modules when it starts out. To decide about the additional items to
7309 install, it just uses data found in the generated Makefile. An
7310 undetected missing piece breaks the process. But it may well be that
7311 your Bundle installs some prerequisite later than some depending item
7312 and thus your second try is able to resolve everything. Please note,
7313 CPAN.pm does not know the dependency tree in advance and cannot sort
7314 the queue of things to install in a topologically correct order. It
7315 resolves perfectly well IFF all modules declare the prerequisites
7316 correctly with the PREREQ_PM attribute to MakeMaker. For bundles which
7317 fail and you need to install often, it is recommended to sort the Bundle
7318 definition file manually. It is planned to improve the metadata
7319 situation for dependencies on CPAN in general, but this will still
7320 take some time.
7321
7322 =item 8)
7323
7324 In our intranet we have many modules for internal use. How
7325 can I integrate these modules with CPAN.pm but without uploading
7326 the modules to CPAN?
7327
7328 Have a look at the CPAN::Site module.
7329
7330 =item 9)
7331
7332 When I run CPAN's shell, I get error msg about line 1 to 4,
7333 setting meta input/output via the /etc/inputrc file.
7334
7335 Some versions of readline are picky about capitalization in the
7336 /etc/inputrc file and specifically RedHat 6.2 comes with a
7337 /etc/inputrc that contains the word C<on> in lowercase. Change the
7338 occurrences of C<on> to C<On> and the bug should disappear.
7339
7340 =item 10)
7341
7342 Some authors have strange characters in their names.
7343
7344 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
7345 expecting ISO-8859-1 charset, a converter can be activated by setting
7346 term_is_latin to a true value in your config file. One way of doing so
7347 would be
7348
7349     cpan> ! $CPAN::Config->{term_is_latin}=1
7350
7351 Extended support for converters will be made available as soon as perl
7352 becomes stable with regard to charset issues.
7353
7354 =item 11)
7355
7356 When an install fails for some reason and then I correct the error
7357 condition and retry, CPAN.pm refuses to install the module, saying
7358 C<Already tried without success>.
7359
7360 Use the force pragma like so
7361
7362   force install Foo::Bar
7363
7364 This does a bit more than really needed because it untars the
7365 distribution again and runs make and test and only then install.
7366
7367 Or, if you find this is too fast and you would prefer to do smaller
7368 steps, say
7369
7370   force get Foo::Bar
7371
7372 first and then continue as always. C<Force get> I<forgets> previous
7373 error conditions.
7374
7375 Or you can use
7376
7377   look Foo::Bar
7378
7379 and then 'make install' directly in the subshell.
7380
7381 Or you leave the CPAN shell and start it again.
7382
7383 For the really curious, by accessing internals directly, you I<could>
7384
7385   ! delete  CPAN::Shell->expand("Distribution", \
7386     CPAN::Shell->expand("Module","Foo::Bar") \
7387     ->cpan_file)->{install}
7388
7389 but this is neither guaranteed to work in the future nor is it a
7390 decent command.
7391
7392 =back
7393
7394 =head1 BUGS
7395
7396 If a Makefile.PL requires special customization of libraries, prompts
7397 the user for special input, etc. then you may find CPAN is not able to
7398 build the distribution. In that case it is recommended to attempt the
7399 traditional method of building a Perl module package from a shell, for
7400 example by using the 'look' command to open a subshell in the
7401 distribution's own directory.
7402
7403 =head1 AUTHOR
7404
7405 Andreas Koenig C<< <andk@cpan.org> >>
7406
7407 =head1 TRANSLATIONS
7408
7409 Kawai,Takanori provides a Japanese translation of this manpage at
7410 http://member.nifty.ne.jp/hippo2000/perltips/CPAN.htm
7411
7412 =head1 SEE ALSO
7413
7414 cpan(1), CPAN::Nox(3pm), CPAN::Version(3pm)
7415
7416 =cut
7417
7418 # Local Variables:
7419 # mode: cperl
7420 # cperl-indent-level: 4
7421 # End: