lib/CPAN.pm

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