lib/CPAN.pm

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