lib/CPAN.pm

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