lib/CPAN.pm

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