lib/CPAN.pm

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