lib/CPAN.pm

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