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     unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
2274         warn "Malformed urllist; ignoring.  Configuration file corrupt?\n";
2275     }
2276     $last = $#{$CPAN::Config->{urllist}};
2277     if ($force & 2) { # local cpans probably out of date, don't reorder
2278         @reordered = (0..$last);
2279     } else {
2280         @reordered =
2281             sort {
2282                 (substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
2283                     <=>
2284                 (substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
2285                     or
2286                 defined($Thesite)
2287                     and
2288                 ($b == $Thesite)
2289                     <=>
2290                 ($a == $Thesite)
2291             } 0..$last;
2292     }
2293     my(@levels);
2294     if ($Themethod) {
2295         @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
2296     } else {
2297         @levels = qw/easy hard hardest/;
2298     }
2299     @levels = qw/easy/ if $^O eq 'MacOS';
2300     my($levelno);
2301     for $levelno (0..$#levels) {
2302         my $level = $levels[$levelno];
2303         my $method = "host$level";
2304         my @host_seq = $level eq "easy" ?
2305             @reordered : 0..$last;  # reordered has CDROM up front
2306         @host_seq = (0) unless @host_seq;
2307         my $ret = $self->$method(\@host_seq,$file,$aslocal);
2308         if ($ret) {
2309           $Themethod = $level;
2310           my $now = time;
2311           # utime $now, $now, $aslocal; # too bad, if we do that, we
2312                                       # might alter a local mirror
2313           $self->debug("level[$level]") if $CPAN::DEBUG;
2314           return $ret;
2315         } else {
2316           unlink $aslocal;
2317           last if $CPAN::Signal; # need to cleanup
2318         }
2319     }
2320     unless ($CPAN::Signal) {
2321         my(@mess);
2322         push @mess,
2323             qq{Please check, if the URLs I found in your configuration file \(}.
2324                 join(", ", @{$CPAN::Config->{urllist}}).
2325                     qq{\) are valid. The urllist can be edited.},
2326                         qq{E.g. with 'o conf urllist push ftp://myurl/'};
2327         $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
2328         sleep 2;
2329         $CPAN::Frontend->myprint("Could not fetch $file\n");
2330     }
2331     if ($restore) {
2332         rename "$aslocal.bak", $aslocal;
2333         $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
2334                                  $self->ls($aslocal));
2335         return $aslocal;
2336     }
2337     return;
2338 }
2339
2340 sub hosteasy {
2341     my($self,$host_seq,$file,$aslocal) = @_;
2342     my($i);
2343   HOSTEASY: for $i (@$host_seq) {
2344         my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2345         $url .= "/" unless substr($url,-1) eq "/";
2346         $url .= $file;
2347         $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
2348         if ($url =~ /^file:/) {
2349             my $l;
2350             if ($CPAN::META->has_inst('URI::URL')) {
2351                 my $u =  URI::URL->new($url);
2352                 $l = $u->path;
2353             } else { # works only on Unix, is poorly constructed, but
2354                 # hopefully better than nothing.
2355                 # RFC 1738 says fileurl BNF is
2356                 # fileurl = "file://" [ host | "localhost" ] "/" fpath
2357                 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
2358                 # the code
2359                 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
2360                 $l =~ s|^file:||;                   # assume they
2361                                                     # meant
2362                                                     # file://localhost
2363                 $l =~ s|^/||s unless -f $l;         # e.g. /P:
2364                 $self->debug("without URI::URL we try local file $l") if $CPAN::DEBUG;
2365             }
2366             if ( -f $l && -r _) {
2367                 $Thesite = $i;
2368                 return $l;
2369             }
2370             # Maybe mirror has compressed it?
2371             if (-f "$l.gz") {
2372                 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
2373                 CPAN::Tarzip->gunzip("$l.gz", $aslocal);
2374                 if ( -f $aslocal) {
2375                     $Thesite = $i;
2376                     return $aslocal;
2377                 }
2378             }
2379         }
2380         if ($CPAN::META->has_usable('LWP')) {
2381           $CPAN::Frontend->myprint("Fetching with LWP:
2382   $url
2383 ");
2384           unless ($Ua) {
2385               CPAN::LWP::UserAgent->config;
2386               eval { $Ua = CPAN::LWP::UserAgent->new; };
2387               if ($@) {
2388                   $CPAN::Frontent->mywarn("CPAN::LWP::UserAgent->new dies with $@");
2389               }
2390           }
2391           my $res = $Ua->mirror($url, $aslocal);
2392           if ($res->is_success) {
2393             $Thesite = $i;
2394             my $now = time;
2395             utime $now, $now, $aslocal; # download time is more
2396                                         # important than upload time
2397             return $aslocal;
2398           } elsif ($url !~ /\.gz(?!\n)\Z/) {
2399             my $gzurl = "$url.gz";
2400             $CPAN::Frontend->myprint("Fetching with LWP:
2401   $gzurl
2402 ");
2403             $res = $Ua->mirror($gzurl, "$aslocal.gz");
2404             if ($res->is_success &&
2405                 CPAN::Tarzip->gunzip("$aslocal.gz",$aslocal)
2406                ) {
2407               $Thesite = $i;
2408               return $aslocal;
2409             }
2410           } else {
2411               $CPAN::Frontend->myprint(sprintf(
2412                                                "LWP failed with code[%s] message[%s]\n",
2413                                                $res->code,
2414                                                $res->message,
2415                                               ));
2416             # Alan Burlison informed me that in firewall environments
2417             # Net::FTP can still succeed where LWP fails. So we do not
2418             # skip Net::FTP anymore when LWP is available.
2419           }
2420         } else {
2421             $CPAN::Frontend->myprint("LWP not available\n");
2422         }
2423         return if $CPAN::Signal;
2424         if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2425             # that's the nice and easy way thanks to Graham
2426             my($host,$dir,$getfile) = ($1,$2,$3);
2427             if ($CPAN::META->has_usable('Net::FTP')) {
2428                 $dir =~ s|/+|/|g;
2429                 $CPAN::Frontend->myprint("Fetching with Net::FTP:
2430   $url
2431 ");
2432                 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
2433                              "aslocal[$aslocal]") if $CPAN::DEBUG;
2434                 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
2435                     $Thesite = $i;
2436                     return $aslocal;
2437                 }
2438                 if ($aslocal !~ /\.gz(?!\n)\Z/) {
2439                     my $gz = "$aslocal.gz";
2440                     $CPAN::Frontend->myprint("Fetching with Net::FTP
2441   $url.gz
2442 ");
2443                    if (CPAN::FTP->ftp_get($host,
2444                                            $dir,
2445                                            "$getfile.gz",
2446                                            $gz) &&
2447                         CPAN::Tarzip->gunzip($gz,$aslocal)
2448                        ){
2449                         $Thesite = $i;
2450                         return $aslocal;
2451                     }
2452                 }
2453                 # next HOSTEASY;
2454             }
2455         }
2456         return if $CPAN::Signal;
2457     }
2458 }
2459
2460 sub hosthard {
2461   my($self,$host_seq,$file,$aslocal) = @_;
2462
2463   # Came back if Net::FTP couldn't establish connection (or
2464   # failed otherwise) Maybe they are behind a firewall, but they
2465   # gave us a socksified (or other) ftp program...
2466
2467   my($i);
2468   my($devnull) = $CPAN::Config->{devnull} || "";
2469   # < /dev/null ";
2470   my($aslocal_dir) = File::Basename::dirname($aslocal);
2471   File::Path::mkpath($aslocal_dir);
2472   HOSTHARD: for $i (@$host_seq) {
2473         my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2474         $url .= "/" unless substr($url,-1) eq "/";
2475         $url .= $file;
2476         my($proto,$host,$dir,$getfile);
2477
2478         # Courtesy Mark Conty mark_conty@cargill.com change from
2479         # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2480         # to
2481         if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
2482           # proto not yet used
2483           ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
2484         } else {
2485           next HOSTHARD; # who said, we could ftp anything except ftp?
2486         }
2487         next HOSTHARD if $proto eq "file"; # file URLs would have had
2488                                            # success above. Likely a bogus URL
2489
2490         $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
2491         my($f,$funkyftp);
2492         for $f ('lynx','ncftpget','ncftp','wget') {
2493           next unless exists $CPAN::Config->{$f};
2494           $funkyftp = $CPAN::Config->{$f};
2495           next unless defined $funkyftp;
2496           next if $funkyftp =~ /^\s*$/;
2497           my($asl_ungz, $asl_gz);
2498           ($asl_ungz = $aslocal) =~ s/\.gz//;
2499           $asl_gz = "$asl_ungz.gz";
2500           my($src_switch) = "";
2501           if ($f eq "lynx"){
2502             $src_switch = " -source";
2503           } elsif ($f eq "ncftp"){
2504             $src_switch = " -c";
2505           } elsif ($f eq "wget"){
2506               $src_switch = " -O -";
2507           }
2508           my($chdir) = "";
2509           my($stdout_redir) = " > $asl_ungz";
2510           if ($f eq "ncftpget"){
2511             $chdir = "cd $aslocal_dir && ";
2512             $stdout_redir = "";
2513           }
2514           $CPAN::Frontend->myprint(
2515                                    qq[
2516 Trying with "$funkyftp$src_switch" to get
2517     $url
2518 ]);
2519           my($system) =
2520               "$chdir$funkyftp$src_switch '$url' $devnull$stdout_redir";
2521           $self->debug("system[$system]") if $CPAN::DEBUG;
2522           my($wstatus);
2523           if (($wstatus = system($system)) == 0
2524               &&
2525               ($f eq "lynx" ?
2526                -s $asl_ungz # lynx returns 0 when it fails somewhere
2527                : 1
2528               )
2529              ) {
2530             if (-s $aslocal) {
2531               # Looks good
2532             } elsif ($asl_ungz ne $aslocal) {
2533               # test gzip integrity
2534               if (CPAN::Tarzip->gtest($asl_ungz)) {
2535                   # e.g. foo.tar is gzipped --> foo.tar.gz
2536                   rename $asl_ungz, $aslocal;
2537               } else {
2538                   CPAN::Tarzip->gzip($asl_ungz,$asl_gz);
2539               }
2540             }
2541             $Thesite = $i;
2542             return $aslocal;
2543           } elsif ($url !~ /\.gz(?!\n)\Z/) {
2544             unlink $asl_ungz if
2545                 -f $asl_ungz && -s _ == 0;
2546             my $gz = "$aslocal.gz";
2547             my $gzurl = "$url.gz";
2548             $CPAN::Frontend->myprint(
2549                                      qq[
2550 Trying with "$funkyftp$src_switch" to get
2551   $url.gz
2552 ]);
2553             my($system) = "$funkyftp$src_switch '$url.gz' $devnull > $asl_gz";
2554             $self->debug("system[$system]") if $CPAN::DEBUG;
2555             my($wstatus);
2556             if (($wstatus = system($system)) == 0
2557                 &&
2558                 -s $asl_gz
2559                ) {
2560               # test gzip integrity
2561               if (CPAN::Tarzip->gtest($asl_gz)) {
2562                   CPAN::Tarzip->gunzip($asl_gz,$aslocal);
2563               } else {
2564                   # somebody uncompressed file for us?
2565                   rename $asl_ungz, $aslocal;
2566               }
2567               $Thesite = $i;
2568               return $aslocal;
2569             } else {
2570               unlink $asl_gz if -f $asl_gz;
2571             }
2572           } else {
2573             my $estatus = $wstatus >> 8;
2574             my $size = -f $aslocal ?
2575                 ", left\n$aslocal with size ".-s _ :
2576                     "\nWarning: expected file [$aslocal] doesn't exist";
2577             $CPAN::Frontend->myprint(qq{
2578 System call "$system"
2579 returned status $estatus (wstat $wstatus)$size
2580 });
2581           }
2582           return if $CPAN::Signal;
2583         } # lynx,ncftpget,ncftp
2584     } # host
2585 }
2586
2587 sub hosthardest {
2588     my($self,$host_seq,$file,$aslocal) = @_;
2589
2590     my($i);
2591     my($aslocal_dir) = File::Basename::dirname($aslocal);
2592     File::Path::mkpath($aslocal_dir);
2593   HOSTHARDEST: for $i (@$host_seq) {
2594         unless (length $CPAN::Config->{'ftp'}) {
2595             $CPAN::Frontend->myprint("No external ftp command available\n\n");
2596             last HOSTHARDEST;
2597         }
2598         my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2599         $url .= "/" unless substr($url,-1) eq "/";
2600         $url .= $file;
2601         $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
2602         unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2603             next;
2604         }
2605         my($host,$dir,$getfile) = ($1,$2,$3);
2606         my $timestamp = 0;
2607         my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
2608            $ctime,$blksize,$blocks) = stat($aslocal);
2609         $timestamp = $mtime ||= 0;
2610         my($netrc) = CPAN::FTP::netrc->new;
2611         my($netrcfile) = $netrc->netrc;
2612         my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
2613         my $targetfile = File::Basename::basename($aslocal);
2614         my(@dialog);
2615         push(
2616              @dialog,
2617              "lcd $aslocal_dir",
2618              "cd /",
2619              map("cd $_", split "/", $dir), # RFC 1738
2620              "bin",
2621              "get $getfile $targetfile",
2622              "quit"
2623             );
2624         if (! $netrcfile) {
2625             CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
2626         } elsif ($netrc->hasdefault || $netrc->contains($host)) {
2627             CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
2628                                 $netrc->hasdefault,
2629                                 $netrc->contains($host))) if $CPAN::DEBUG;
2630             if ($netrc->protected) {
2631                 $CPAN::Frontend->myprint(qq{
2632   Trying with external ftp to get
2633     $url
2634   As this requires some features that are not thoroughly tested, we\'re
2635   not sure, that we get it right....
2636
2637 }
2638                      );
2639                 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose $host",
2640                                 @dialog);
2641                 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2642                  $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2643                 $mtime ||= 0;
2644                 if ($mtime > $timestamp) {
2645                     $CPAN::Frontend->myprint("GOT $aslocal\n");
2646                     $Thesite = $i;
2647                     return $aslocal;
2648                 } else {
2649                     $CPAN::Frontend->myprint("Hmm... Still failed!\n");
2650                 }
2651                 return if $CPAN::Signal;
2652             } else {
2653                 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
2654                                         qq{correctly protected.\n});
2655             }
2656         } else {
2657             $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
2658   nor does it have a default entry\n");
2659         }
2660
2661         # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
2662         # then and login manually to host, using e-mail as
2663         # password.
2664         $CPAN::Frontend->myprint(qq{Issuing "$CPAN::Config->{'ftp'}$verbose -n"\n});
2665         unshift(
2666                 @dialog,
2667                 "open $host",
2668                 "user anonymous $Config::Config{'cf_email'}"
2669                );
2670         $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose -n", @dialog);
2671         ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2672          $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2673         $mtime ||= 0;
2674         if ($mtime > $timestamp) {
2675             $CPAN::Frontend->myprint("GOT $aslocal\n");
2676             $Thesite = $i;
2677             return $aslocal;
2678         } else {
2679             $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
2680         }
2681         return if $CPAN::Signal;
2682         $CPAN::Frontend->myprint("Can't access URL $url.\n\n");
2683         sleep 2;
2684     } # host
2685 }
2686
2687 sub talk_ftp {
2688     my($self,$command,@dialog) = @_;
2689     my $fh = FileHandle->new;
2690     $fh->open("|$command") or die "Couldn't open ftp: $!";
2691     foreach (@dialog) { $fh->print("$_\n") }
2692     $fh->close;         # Wait for process to complete
2693     my $wstatus = $?;
2694     my $estatus = $wstatus >> 8;
2695     $CPAN::Frontend->myprint(qq{
2696 Subprocess "|$command"
2697   returned status $estatus (wstat $wstatus)
2698 }) if $wstatus;
2699 }
2700
2701 # find2perl needs modularization, too, all the following is stolen
2702 # from there
2703 # CPAN::FTP::ls
2704 sub ls {
2705     my($self,$name) = @_;
2706     my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
2707      $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
2708
2709     my($perms,%user,%group);
2710     my $pname = $name;
2711
2712     if ($blocks) {
2713         $blocks = int(($blocks + 1) / 2);
2714     }
2715     else {
2716         $blocks = int(($sizemm + 1023) / 1024);
2717     }
2718
2719     if    (-f _) { $perms = '-'; }
2720     elsif (-d _) { $perms = 'd'; }
2721     elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
2722     elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
2723     elsif (-p _) { $perms = 'p'; }
2724     elsif (-S _) { $perms = 's'; }
2725     else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
2726
2727     my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
2728     my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
2729     my $tmpmode = $mode;
2730     my $tmp = $rwx[$tmpmode & 7];
2731     $tmpmode >>= 3;
2732     $tmp = $rwx[$tmpmode & 7] . $tmp;
2733     $tmpmode >>= 3;
2734     $tmp = $rwx[$tmpmode & 7] . $tmp;
2735     substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
2736     substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
2737     substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
2738     $perms .= $tmp;
2739
2740     my $user = $user{$uid} || $uid;   # too lazy to implement lookup
2741     my $group = $group{$gid} || $gid;
2742
2743     my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
2744     my($timeyear);
2745     my($moname) = $moname[$mon];
2746     if (-M _ > 365.25 / 2) {
2747         $timeyear = $year + 1900;
2748     }
2749     else {
2750         $timeyear = sprintf("%02d:%02d", $hour, $min);
2751     }
2752
2753     sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
2754             $ino,
2755                  $blocks,
2756                       $perms,
2757                             $nlink,
2758                                 $user,
2759                                      $group,
2760                                           $sizemm,
2761                                               $moname,
2762                                                  $mday,
2763                                                      $timeyear,
2764                                                          $pname;
2765 }
2766
2767 package CPAN::FTP::netrc;
2768
2769 sub new {
2770     my($class) = @_;
2771     my $file = File::Spec->catfile($ENV{HOME},".netrc");
2772
2773     my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2774        $atime,$mtime,$ctime,$blksize,$blocks)
2775         = stat($file);
2776     $mode ||= 0;
2777     my $protected = 0;
2778
2779     my($fh,@machines,$hasdefault);
2780     $hasdefault = 0;
2781     $fh = FileHandle->new or die "Could not create a filehandle";
2782
2783     if($fh->open($file)){
2784         $protected = ($mode & 077) == 0;
2785         local($/) = "";
2786       NETRC: while (<$fh>) {
2787             my(@tokens) = split " ", $_;
2788           TOKEN: while (@tokens) {
2789                 my($t) = shift @tokens;
2790                 if ($t eq "default"){
2791                     $hasdefault++;
2792                     last NETRC;
2793                 }
2794                 last TOKEN if $t eq "macdef";
2795                 if ($t eq "machine") {
2796                     push @machines, shift @tokens;
2797                 }
2798             }
2799         }
2800     } else {
2801         $file = $hasdefault = $protected = "";
2802     }
2803
2804     bless {
2805            'mach' => [@machines],
2806            'netrc' => $file,
2807            'hasdefault' => $hasdefault,
2808            'protected' => $protected,
2809           }, $class;
2810 }
2811
2812 # CPAN::FTP::hasdefault;
2813 sub hasdefault { shift->{'hasdefault'} }
2814 sub netrc      { shift->{'netrc'}      }
2815 sub protected  { shift->{'protected'}  }
2816 sub contains {
2817     my($self,$mach) = @_;
2818     for ( @{$self->{'mach'}} ) {
2819         return 1 if $_ eq $mach;
2820     }
2821     return 0;
2822 }
2823
2824 package CPAN::Complete;
2825
2826 sub gnu_cpl {
2827     my($text, $line, $start, $end) = @_;
2828     my(@perlret) = cpl($text, $line, $start);
2829     # find longest common match. Can anybody show me how to peruse
2830     # T::R::Gnu to have this done automatically? Seems expensive.
2831     return () unless @perlret;
2832     my($newtext) = $text;
2833     for (my $i = length($text)+1;;$i++) {
2834         last unless length($perlret[0]) && length($perlret[0]) >= $i;
2835         my $try = substr($perlret[0],0,$i);
2836         my @tries = grep {substr($_,0,$i) eq $try} @perlret;
2837         # warn "try[$try]tries[@tries]";
2838         if (@tries == @perlret) {
2839             $newtext = $try;
2840         } else {
2841             last;
2842         }
2843     }
2844     ($newtext,@perlret);
2845 }
2846
2847 #-> sub CPAN::Complete::cpl ;
2848 sub cpl {
2849     my($word,$line,$pos) = @_;
2850     $word ||= "";
2851     $line ||= "";
2852     $pos ||= 0;
2853     CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2854     $line =~ s/^\s*//;
2855     if ($line =~ s/^(force\s*)//) {
2856         $pos -= length($1);
2857     }
2858     my @return;
2859     if ($pos == 0) {
2860         @return = grep /^$word/, @CPAN::Complete::COMMANDS;
2861     } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
2862         @return = ();
2863     } elsif ($line =~ /^(a|ls)\s/) {
2864         @return = cplx('CPAN::Author',uc($word));
2865     } elsif ($line =~ /^b\s/) {
2866         CPAN::Shell->local_bundles;
2867         @return = cplx('CPAN::Bundle',$word);
2868     } elsif ($line =~ /^d\s/) {
2869         @return = cplx('CPAN::Distribution',$word);
2870     } elsif ($line =~ m/^(
2871                           [mru]|make|clean|dump|get|test|install|readme|look|cvs_import
2872                          )\s/x ) {
2873         if ($word =~ /^Bundle::/) {
2874             CPAN::Shell->local_bundles;
2875         }
2876         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
2877     } elsif ($line =~ /^i\s/) {
2878         @return = cpl_any($word);
2879     } elsif ($line =~ /^reload\s/) {
2880         @return = cpl_reload($word,$line,$pos);
2881     } elsif ($line =~ /^o\s/) {
2882         @return = cpl_option($word,$line,$pos);
2883     } elsif ($line =~ m/^\S+\s/ ) {
2884         # fallback for future commands and what we have forgotten above
2885         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
2886     } else {
2887         @return = ();
2888     }
2889     return @return;
2890 }
2891
2892 #-> sub CPAN::Complete::cplx ;
2893 sub cplx {
2894     my($class, $word) = @_;
2895     # I believed for many years that this was sorted, today I
2896     # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
2897     # make it sorted again. Maybe sort was dropped when GNU-readline
2898     # support came in? The RCS file is difficult to read on that:-(
2899     sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
2900 }
2901
2902 #-> sub CPAN::Complete::cpl_any ;
2903 sub cpl_any {
2904     my($word) = shift;
2905     return (
2906             cplx('CPAN::Author',$word),
2907             cplx('CPAN::Bundle',$word),
2908             cplx('CPAN::Distribution',$word),
2909             cplx('CPAN::Module',$word),
2910            );
2911 }
2912
2913 #-> sub CPAN::Complete::cpl_reload ;
2914 sub cpl_reload {
2915     my($word,$line,$pos) = @_;
2916     $word ||= "";
2917     my(@words) = split " ", $line;
2918     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2919     my(@ok) = qw(cpan index);
2920     return @ok if @words == 1;
2921     return grep /^\Q$word\E/, @ok if @words == 2 && $word;
2922 }
2923
2924 #-> sub CPAN::Complete::cpl_option ;
2925 sub cpl_option {
2926     my($word,$line,$pos) = @_;
2927     $word ||= "";
2928     my(@words) = split " ", $line;
2929     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2930     my(@ok) = qw(conf debug);
2931     return @ok if @words == 1;
2932     return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
2933     if (0) {
2934     } elsif ($words[1] eq 'index') {
2935         return ();
2936     } elsif ($words[1] eq 'conf') {
2937         return CPAN::Config::cpl(@_);
2938     } elsif ($words[1] eq 'debug') {
2939         return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all';
2940     }
2941 }
2942
2943 package CPAN::Index;
2944
2945 #-> sub CPAN::Index::force_reload ;
2946 sub force_reload {
2947     my($class) = @_;
2948     $CPAN::Index::LAST_TIME = 0;
2949     $class->reload(1);
2950 }
2951
2952 #-> sub CPAN::Index::reload ;
2953 sub reload {
2954     my($cl,$force) = @_;
2955     my $time = time;
2956
2957     # XXX check if a newer one is available. (We currently read it
2958     # from time to time)
2959     for ($CPAN::Config->{index_expire}) {
2960         $_ = 0.001 unless $_ && $_ > 0.001;
2961     }
2962     unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
2963         # debug here when CPAN doesn't seem to read the Metadata
2964         require Carp;
2965         Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
2966     }
2967     unless ($CPAN::META->{PROTOCOL}) {
2968         $cl->read_metadata_cache;
2969         $CPAN::META->{PROTOCOL} ||= "1.0";
2970     }
2971     if ( $CPAN::META->{PROTOCOL} < PROTOCOL  ) {
2972         # warn "Setting last_time to 0";
2973         $LAST_TIME = 0; # No warning necessary
2974     }
2975     return if $LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
2976         and ! $force;
2977     if (0) {
2978         # IFF we are developing, it helps to wipe out the memory
2979         # between reloads, otherwise it is not what a user expects.
2980         undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
2981         $CPAN::META = CPAN->new;
2982     }
2983     {
2984         my($debug,$t2);
2985         local $LAST_TIME = $time;
2986         local $CPAN::META->{PROTOCOL} = PROTOCOL;
2987
2988         my $needshort = $^O eq "dos";
2989
2990         $cl->rd_authindex($cl
2991                           ->reload_x(
2992                                      "authors/01mailrc.txt.gz",
2993                                      $needshort ?
2994                                      File::Spec->catfile('authors', '01mailrc.gz') :
2995                                      File::Spec->catfile('authors', '01mailrc.txt.gz'),
2996                                      $force));
2997         $t2 = time;
2998         $debug = "timing reading 01[".($t2 - $time)."]";
2999         $time = $t2;
3000         return if $CPAN::Signal; # this is sometimes lengthy
3001         $cl->rd_modpacks($cl
3002                          ->reload_x(
3003                                     "modules/02packages.details.txt.gz",
3004                                     $needshort ?
3005                                     File::Spec->catfile('modules', '02packag.gz') :
3006                                     File::Spec->catfile('modules', '02packages.details.txt.gz'),
3007                                     $force));
3008         $t2 = time;
3009         $debug .= "02[".($t2 - $time)."]";
3010         $time = $t2;
3011         return if $CPAN::Signal; # this is sometimes lengthy
3012         $cl->rd_modlist($cl
3013                         ->reload_x(
3014                                    "modules/03modlist.data.gz",
3015                                    $needshort ?
3016                                    File::Spec->catfile('modules', '03mlist.gz') :
3017                                    File::Spec->catfile('modules', '03modlist.data.gz'),
3018                                    $force));
3019         $cl->write_metadata_cache;
3020         $t2 = time;
3021         $debug .= "03[".($t2 - $time)."]";
3022         $time = $t2;
3023         CPAN->debug($debug) if $CPAN::DEBUG;
3024     }
3025     $LAST_TIME = $time;
3026     $CPAN::META->{PROTOCOL} = PROTOCOL;
3027 }
3028
3029 #-> sub CPAN::Index::reload_x ;
3030 sub reload_x {
3031     my($cl,$wanted,$localname,$force) = @_;
3032     $force |= 2; # means we're dealing with an index here
3033     CPAN::Config->load; # we should guarantee loading wherever we rely
3034                         # on Config XXX
3035     $localname ||= $wanted;
3036     my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
3037                                          $localname);
3038     if (
3039         -f $abs_wanted &&
3040         -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
3041         !($force & 1)
3042        ) {
3043         my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
3044         $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
3045                    qq{day$s. I\'ll use that.});
3046         return $abs_wanted;
3047     } else {
3048         $force |= 1; # means we're quite serious about it.
3049     }
3050     return CPAN::FTP->localize($wanted,$abs_wanted,$force);
3051 }
3052
3053 #-> sub CPAN::Index::rd_authindex ;
3054 sub rd_authindex {
3055     my($cl, $index_target) = @_;
3056     my @lines;
3057     return unless defined $index_target;
3058     $CPAN::Frontend->myprint("Going to read $index_target\n");
3059     local(*FH);
3060     tie *FH, CPAN::Tarzip, $index_target;
3061     local($/) = "\n";
3062     push @lines, split /\012/ while <FH>;
3063     foreach (@lines) {
3064         my($userid,$fullname,$email) =
3065             m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
3066         next unless $userid && $fullname && $email;
3067
3068         # instantiate an author object
3069         my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
3070         $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
3071         return if $CPAN::Signal;
3072     }
3073 }
3074
3075 sub userid {
3076   my($self,$dist) = @_;
3077   $dist = $self->{'id'} unless defined $dist;
3078   my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
3079   $ret;
3080 }
3081
3082 #-> sub CPAN::Index::rd_modpacks ;
3083 sub rd_modpacks {
3084     my($self, $index_target) = @_;
3085     my @lines;
3086     return unless defined $index_target;
3087     $CPAN::Frontend->myprint("Going to read $index_target\n");
3088     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3089     local($/) = "\n";
3090     while ($_ = $fh->READLINE) {
3091         s/\012/\n/g;
3092         my @ls = map {"$_\n"} split /\n/, $_;
3093         unshift @ls, "\n" x length($1) if /^(\n+)/;
3094         push @lines, @ls;
3095     }
3096     # read header
3097     my($line_count,$last_updated);
3098     while (@lines) {
3099         my $shift = shift(@lines);
3100         last if $shift =~ /^\s*$/;
3101         $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
3102         $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
3103     }
3104     if (not defined $line_count) {
3105
3106         warn qq{Warning: Your $index_target does not contain a Line-Count header.
3107 Please check the validity of the index file by comparing it to more
3108 than one CPAN mirror. I'll continue but problems seem likely to
3109 happen.\a
3110 };
3111
3112         sleep 5;
3113     } elsif ($line_count != scalar @lines) {
3114
3115         warn sprintf qq{Warning: Your %s
3116 contains a Line-Count header of %d but I see %d lines there. Please
3117 check the validity of the index file by comparing it to more than one
3118 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
3119 $index_target, $line_count, scalar(@lines);
3120
3121     }
3122     if (not defined $last_updated) {
3123
3124         warn qq{Warning: Your $index_target does not contain a Last-Updated header.
3125 Please check the validity of the index file by comparing it to more
3126 than one CPAN mirror. I'll continue but problems seem likely to
3127 happen.\a
3128 };
3129
3130         sleep 5;
3131     } else {
3132
3133         $CPAN::Frontend
3134             ->myprint(sprintf qq{  Database was generated on %s\n},
3135                       $last_updated);
3136         $DATE_OF_02 = $last_updated;
3137
3138         if ($CPAN::META->has_inst(HTTP::Date)) {
3139             require HTTP::Date;
3140             my($age) = (time - HTTP::Date::str2time($last_updated))/3600/24;
3141             if ($age > 30) {
3142
3143                 $CPAN::Frontend
3144                     ->mywarn(sprintf
3145                              qq{Warning: This index file is %d days old.
3146   Please check the host you chose as your CPAN mirror for staleness.
3147   I'll continue but problems seem likely to happen.\a\n},
3148                              $age);
3149
3150             }
3151         } else {
3152             $CPAN::Frontend->myprint("  HTTP::Date not available\n");
3153         }
3154     }
3155
3156
3157     # A necessity since we have metadata_cache: delete what isn't
3158     # there anymore
3159     my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
3160     CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
3161     my(%exists);
3162     foreach (@lines) {
3163         chomp;
3164         # before 1.56 we split into 3 and discarded the rest. From
3165         # 1.57 we assign remaining text to $comment thus allowing to
3166         # influence isa_perl
3167         my($mod,$version,$dist,$comment) = split " ", $_, 4;
3168         my($bundle,$id,$userid);
3169
3170         if ($mod eq 'CPAN' &&
3171             ! (
3172                CPAN::Queue->exists('Bundle::CPAN') ||
3173                CPAN::Queue->exists('CPAN')
3174               )
3175            ) {
3176             local($^W)= 0;
3177             if ($version > $CPAN::VERSION){
3178                 $CPAN::Frontend->myprint(qq{
3179   There's a new CPAN.pm version (v$version) available!
3180   [Current version is v$CPAN::VERSION]
3181   You might want to try
3182     install Bundle::CPAN
3183     reload cpan
3184   without quitting the current session. It should be a seamless upgrade
3185   while we are running...
3186 }); #});
3187                 sleep 2;
3188                 $CPAN::Frontend->myprint(qq{\n});
3189             }
3190             last if $CPAN::Signal;
3191         } elsif ($mod =~ /^Bundle::(.*)/) {
3192             $bundle = $1;
3193         }
3194
3195         if ($bundle){
3196             $id =  $CPAN::META->instance('CPAN::Bundle',$mod);
3197             # Let's make it a module too, because bundles have so much
3198             # in common with modules.
3199
3200             # Changed in 1.57_63: seems like memory bloat now without
3201             # any value, so commented out
3202
3203             # $CPAN::META->instance('CPAN::Module',$mod);
3204
3205         } else {
3206
3207             # instantiate a module object
3208             $id = $CPAN::META->instance('CPAN::Module',$mod);
3209
3210         }
3211
3212         if ($id->cpan_file ne $dist){ # update only if file is
3213                                       # different. CPAN prohibits same
3214                                       # name with different version
3215             $userid = $self->userid($dist);
3216             $id->set(
3217                      'CPAN_USERID' => $userid,
3218                      'CPAN_VERSION' => $version,
3219                      'CPAN_FILE' => $dist,
3220                     );
3221         }
3222
3223         # instantiate a distribution object
3224         if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
3225           # we do not need CONTAINSMODS unless we do something with
3226           # this dist, so we better produce it on demand.
3227
3228           ## my $obj = $CPAN::META->instance(
3229           ##                              'CPAN::Distribution' => $dist
3230           ##                             );
3231           ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
3232         } else {
3233           $CPAN::META->instance(
3234                                 'CPAN::Distribution' => $dist
3235                                )->set(
3236                                       'CPAN_USERID' => $userid,
3237                                       'CPAN_COMMENT' => $comment,
3238                                      );
3239         }
3240         if ($secondtime) {
3241             for my $name ($mod,$dist) {
3242                 CPAN->debug("exists name[$name]") if $CPAN::DEBUG;
3243                 $exists{$name} = undef;
3244             }
3245         }
3246         return if $CPAN::Signal;
3247     }
3248     undef $fh;
3249     if ($secondtime) {
3250         for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
3251             for my $o ($CPAN::META->all_objects($class)) {
3252                 next if exists $exists{$o->{ID}};
3253                 $CPAN::META->delete($class,$o->{ID});
3254                 CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
3255                     if $CPAN::DEBUG;
3256             }
3257         }
3258     }
3259 }
3260
3261 #-> sub CPAN::Index::rd_modlist ;
3262 sub rd_modlist {
3263     my($cl,$index_target) = @_;
3264     return unless defined $index_target;
3265     $CPAN::Frontend->myprint("Going to read $index_target\n");
3266     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3267     my @eval;
3268     local($/) = "\n";
3269     while ($_ = $fh->READLINE) {
3270         s/\012/\n/g;
3271         my @ls = map {"$_\n"} split /\n/, $_;
3272         unshift @ls, "\n" x length($1) if /^(\n+)/;
3273         push @eval, @ls;
3274     }
3275     while (@eval) {
3276         my $shift = shift(@eval);
3277         if ($shift =~ /^Date:\s+(.*)/){
3278             return if $DATE_OF_03 eq $1;
3279             ($DATE_OF_03) = $1;
3280         }
3281         last if $shift =~ /^\s*$/;
3282     }
3283     undef $fh;
3284     push @eval, q{CPAN::Modulelist->data;};
3285     local($^W) = 0;
3286     my($comp) = Safe->new("CPAN::Safe1");
3287     my($eval) = join("", @eval);
3288     my $ret = $comp->reval($eval);
3289     Carp::confess($@) if $@;
3290     return if $CPAN::Signal;
3291     for (keys %$ret) {
3292         my $obj = $CPAN::META->instance("CPAN::Module",$_);
3293         delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
3294         $obj->set(%{$ret->{$_}});
3295         return if $CPAN::Signal;
3296     }
3297 }
3298
3299 #-> sub CPAN::Index::write_metadata_cache ;
3300 sub write_metadata_cache {
3301     my($self) = @_;
3302     return unless $CPAN::Config->{'cache_metadata'};
3303     return unless $CPAN::META->has_usable("Storable");
3304     my $cache;
3305     foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
3306                       CPAN::Distribution)) {
3307         $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
3308     }
3309     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
3310     $cache->{last_time} = $LAST_TIME;
3311     $cache->{DATE_OF_02} = $DATE_OF_02;
3312     $cache->{PROTOCOL} = PROTOCOL;
3313     $CPAN::Frontend->myprint("Going to write $metadata_file\n");
3314     eval { Storable::nstore($cache, $metadata_file) };
3315     $CPAN::Frontend->mywarn($@) if $@;
3316 }
3317
3318 #-> sub CPAN::Index::read_metadata_cache ;
3319 sub read_metadata_cache {
3320     my($self) = @_;
3321     return unless $CPAN::Config->{'cache_metadata'};
3322     return unless $CPAN::META->has_usable("Storable");
3323     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
3324     return unless -r $metadata_file and -f $metadata_file;
3325     $CPAN::Frontend->myprint("Going to read $metadata_file\n");
3326     my $cache;
3327     eval { $cache = Storable::retrieve($metadata_file) };
3328     $CPAN::Frontend->mywarn($@) if $@;
3329     if (!$cache || ref $cache ne 'HASH'){
3330         $LAST_TIME = 0;
3331         return;
3332     }
3333     if (exists $cache->{PROTOCOL}) {
3334         if (PROTOCOL > $cache->{PROTOCOL}) {
3335             $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
3336                                             "with protocol v%s, requiring v%s",
3337                                             $cache->{PROTOCOL},
3338                                             PROTOCOL)
3339                                    );
3340             return;
3341         }
3342     } else {
3343         $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
3344                                 "with protocol v1.0");
3345         return;
3346     }
3347     my $clcnt = 0;
3348     my $idcnt = 0;
3349     while(my($class,$v) = each %$cache) {
3350         next unless $class =~ /^CPAN::/;
3351         $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
3352         while (my($id,$ro) = each %$v) {
3353             $CPAN::META->{readwrite}{$class}{$id} ||=
3354                 $class->new(ID=>$id, RO=>$ro);
3355             $idcnt++;
3356         }
3357         $clcnt++;
3358     }
3359     unless ($clcnt) { # sanity check
3360         $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
3361         return;
3362     }
3363     if ($idcnt < 1000) {
3364         $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
3365                                  "in $metadata_file\n");
3366         return;
3367     }
3368     $CPAN::META->{PROTOCOL} ||=
3369         $cache->{PROTOCOL}; # reading does not up or downgrade, but it
3370                             # does initialize to some protocol
3371     $LAST_TIME = $cache->{last_time};
3372     $DATE_OF_02 = $cache->{DATE_OF_02};
3373     $CPAN::Frontend->myprint("  Database was generated on $DATE_OF_02\n")
3374         if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
3375     return;
3376 }
3377
3378 package CPAN::InfoObj;
3379
3380 # Accessors
3381 sub cpan_userid { shift->{RO}{CPAN_USERID} }
3382 sub id { shift->{ID}; }
3383
3384 #-> sub CPAN::InfoObj::new ;
3385 sub new {
3386     my $this = bless {}, shift;
3387     %$this = @_;
3388     $this
3389 }
3390
3391 # The set method may only be used by code that reads index data or
3392 # otherwise "objective" data from the outside world. All session
3393 # related material may do anything else with instance variables but
3394 # must not touch the hash under the RO attribute. The reason is that
3395 # the RO hash gets written to Metadata file and is thus persistent.
3396
3397 #-> sub CPAN::InfoObj::set ;
3398 sub set {
3399     my($self,%att) = @_;
3400     my $class = ref $self;
3401
3402     # This must be ||=, not ||, because only if we write an empty
3403     # reference, only then the set method will write into the readonly
3404     # area. But for Distributions that spring into existence, maybe
3405     # because of a typo, we do not like it that they are written into
3406     # the readonly area and made permanent (at least for a while) and
3407     # that is why we do not "allow" other places to call ->set.
3408     unless ($self->id) {
3409         CPAN->debug("Bug? Empty ID, rejecting");
3410         return;
3411     }
3412     my $ro = $self->{RO} =
3413         $CPAN::META->{readonly}{$class}{$self->id} ||= {};
3414
3415     while (my($k,$v) = each %att) {
3416         $ro->{$k} = $v;
3417     }
3418 }
3419
3420 #-> sub CPAN::InfoObj::as_glimpse ;
3421 sub as_glimpse {
3422     my($self) = @_;
3423     my(@m);
3424     my $class = ref($self);
3425     $class =~ s/^CPAN:://;
3426     push @m, sprintf "%-15s %s\n", $class, $self->{ID};
3427     join "", @m;
3428 }
3429
3430 #-> sub CPAN::InfoObj::as_string ;
3431 sub as_string {
3432     my($self) = @_;
3433     my(@m);
3434     my $class = ref($self);
3435     $class =~ s/^CPAN:://;
3436     push @m, $class, " id = $self->{ID}\n";
3437     for (sort keys %{$self->{RO}}) {
3438         # next if m/^(ID|RO)$/;
3439         my $extra = "";
3440         if ($_ eq "CPAN_USERID") {
3441             $extra .= " (".$self->author;
3442             my $email; # old perls!
3443             if ($email = $CPAN::META->instance("CPAN::Author",
3444                                                $self->cpan_userid
3445                                               )->email) {
3446                 $extra .= " <$email>";
3447             } else {
3448                 $extra .= " <no email>";
3449             }
3450             $extra .= ")";
3451         } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
3452             push @m, sprintf "    %-12s %s\n", $_, $self->fullname;
3453             next;
3454         }
3455         next unless defined $self->{RO}{$_};
3456         push @m, sprintf "    %-12s %s%s\n", $_, $self->{RO}{$_}, $extra;
3457     }
3458     for (sort keys %$self) {
3459         next if m/^(ID|RO)$/;
3460         if (ref($self->{$_}) eq "ARRAY") {
3461           push @m, sprintf "    %-12s %s\n", $_, "@{$self->{$_}}";
3462         } elsif (ref($self->{$_}) eq "HASH") {
3463           push @m, sprintf(
3464                            "    %-12s %s\n",
3465                            $_,
3466                            join(" ",keys %{$self->{$_}}),
3467                           );
3468         } else {
3469           push @m, sprintf "    %-12s %s\n", $_, $self->{$_};
3470         }
3471     }
3472     join "", @m, "\n";
3473 }
3474
3475 #-> sub CPAN::InfoObj::author ;
3476 sub author {
3477     my($self) = @_;
3478     $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
3479 }
3480
3481 #-> sub CPAN::InfoObj::dump ;
3482 sub dump {
3483   my($self) = @_;
3484   require Data::Dumper;
3485   print Data::Dumper::Dumper($self);
3486 }
3487
3488 package CPAN::Author;
3489
3490 #-> sub CPAN::Author::id
3491 sub id {
3492     my $self = shift;
3493     my $id = $self->{ID};
3494     $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
3495     $id;
3496 }
3497
3498 #-> sub CPAN::Author::as_glimpse ;
3499 sub as_glimpse {
3500     my($self) = @_;
3501     my(@m);
3502     my $class = ref($self);
3503     $class =~ s/^CPAN:://;
3504     push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
3505                      $class,
3506                      $self->{ID},
3507                      $self->fullname,
3508                      $self->email);
3509     join "", @m;
3510 }
3511
3512 #-> sub CPAN::Author::fullname ;
3513 sub fullname {
3514     shift->{RO}{FULLNAME};
3515 }
3516 *name = \&fullname;
3517
3518 #-> sub CPAN::Author::email ;
3519 sub email    { shift->{RO}{EMAIL}; }
3520
3521 #-> sub CPAN::Author::ls ;
3522 sub ls {
3523     my $self = shift;
3524     my $id = $self->id;
3525
3526     # adapted from CPAN::Distribution::verifyMD5 ;
3527     my(@csf); # chksumfile
3528     @csf = $self->id =~ /(.)(.)(.*)/;
3529     $csf[1] = join "", @csf[0,1];
3530     $csf[2] = join "", @csf[1,2];
3531     my(@dl);
3532     @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0);
3533     unless (grep {$_->[2] eq $csf[1]} @dl) {
3534         $CPAN::Frontend->myprint("No files in the directory of $id\n");
3535         return;
3536     }
3537     @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0);
3538     unless (grep {$_->[2] eq $csf[2]} @dl) {
3539         $CPAN::Frontend->myprint("No files in the directory of $id\n");
3540         return;
3541     }
3542     @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1);
3543     $CPAN::Frontend->myprint(join "", map {
3544         sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
3545     } sort { $a->[2] cmp $b->[2] } @dl);
3546 }
3547
3548 # returns an array of arrays, the latter contain (size,mtime,filename)
3549 #-> sub CPAN::Author::dir_listing ;
3550 sub dir_listing {
3551     my $self = shift;
3552     my $chksumfile = shift;
3553     my $recursive = shift;
3554     my $lc_want =
3555         File::Spec->catfile($CPAN::Config->{keep_source_where},
3556                             "authors", "id", @$chksumfile);
3557     local($") = "/";
3558     # connect "force" argument with "index_expire".
3559     my $force = 0;
3560     if (my @stat = stat $lc_want) {
3561         $force = $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
3562     }
3563     my $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
3564                                       $lc_want,$force);
3565     unless ($lc_file) {
3566         $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
3567         $chksumfile->[-1] .= ".gz";
3568         $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
3569                                        "$lc_want.gz",1);
3570         if ($lc_file) {
3571             $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
3572             CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
3573         } else {
3574             return;
3575         }
3576     }
3577
3578     # adapted from CPAN::Distribution::MD5_check_file ;
3579     my $fh = FileHandle->new;
3580     my($cksum);
3581     if (open $fh, $lc_file){
3582         local($/);
3583         my $eval = <$fh>;
3584         $eval =~ s/\015?\012/\n/g;
3585         close $fh;
3586         my($comp) = Safe->new();
3587         $cksum = $comp->reval($eval);
3588         if ($@) {
3589             rename $lc_file, "$lc_file.bad";
3590             Carp::confess($@) if $@;
3591         }
3592     } else {
3593         Carp::carp "Could not open $lc_file for reading";
3594     }
3595     my(@result,$f);
3596     for $f (sort keys %$cksum) {
3597         if (exists $cksum->{$f}{isdir}) {
3598             if ($recursive) {
3599                 my(@dir) = @$chksumfile;
3600                 pop @dir;
3601                 push @dir, $f, "CHECKSUMS";
3602                 push @result, map {
3603                     [$_->[0], $_->[1], "$f/$_->[2]"]
3604                 } $self->dir_listing(\@dir,1);
3605             } else {
3606                 push @result, [ 0, "-", $f ];
3607             }
3608         } else {
3609             push @result, [
3610                            ($cksum->{$f}{"size"}||0),
3611                            $cksum->{$f}{"mtime"}||"---",
3612                            $f
3613                           ];
3614         }
3615     }
3616     @result;
3617 }
3618
3619 package CPAN::Distribution;
3620
3621 # Accessors
3622 sub cpan_comment { shift->{RO}{CPAN_COMMENT} }
3623
3624 sub undelay {
3625     my $self = shift;
3626     delete $self->{later};
3627 }
3628
3629 # CPAN::Distribution::normalize
3630 sub normalize {
3631     my($self,$s) = @_;
3632     $s = $self->id unless defined $s;
3633     if (
3634         $s =~ tr|/|| == 1
3635         or
3636         $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
3637        ) {
3638         return $s if $s =~ m:^N/A|^Contact Author: ;
3639         $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
3640             $CPAN::Frontend->mywarn("Strange distribution name [$s]");
3641         CPAN->debug("s[$s]") if $CPAN::DEBUG;
3642     }
3643     $s;
3644 }
3645
3646 #-> sub CPAN::Distribution::color_cmd_tmps ;
3647 sub color_cmd_tmps {
3648     my($self) = shift;
3649     my($depth) = shift || 0;
3650     my($color) = shift || 0;
3651     # a distribution needs to recurse into its prereq_pms
3652
3653     return if exists $self->{incommandcolor}
3654         && $self->{incommandcolor}==$color;
3655     $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
3656                                    "color_cmd_tmps depth[%s] self[%s] id[%s]",
3657                                    $depth,
3658                                    $self,
3659                                    $self->id
3660                                   )) if $depth>=100;
3661     ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
3662     my $prereq_pm = $self->prereq_pm;
3663     if (defined $prereq_pm) {
3664         for my $pre (keys %$prereq_pm) {
3665             my $premo = CPAN::Shell->expand("Module",$pre);
3666             $premo->color_cmd_tmps($depth+1,$color);
3667         }
3668     }
3669     if ($color==0) {
3670         delete $self->{sponsored_mods};
3671         delete $self->{badtestcnt};
3672     }
3673     $self->{incommandcolor} = $color;
3674 }
3675
3676 #-> sub CPAN::Distribution::as_string ;
3677 sub as_string {
3678   my $self = shift;
3679   $self->containsmods;
3680   $self->SUPER::as_string(@_);
3681 }
3682
3683 #-> sub CPAN::Distribution::containsmods ;
3684 sub containsmods {
3685   my $self = shift;
3686   return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
3687   my $dist_id = $self->{ID};
3688   for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
3689     my $mod_file = $mod->cpan_file or next;
3690     my $mod_id = $mod->{ID} or next;
3691     # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
3692     # sleep 1;
3693     $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
3694   }
3695   keys %{$self->{CONTAINSMODS}};
3696 }
3697
3698 #-> sub CPAN::Distribution::uptodate ;
3699 sub uptodate {
3700     my($self) = @_;
3701     my $c;
3702     foreach $c ($self->containsmods) {
3703         my $obj = CPAN::Shell->expandany($c);
3704         return 0 unless $obj->uptodate;
3705     }
3706     return 1;
3707 }
3708
3709 #-> sub CPAN::Distribution::called_for ;
3710 sub called_for {
3711     my($self,$id) = @_;
3712     $self->{CALLED_FOR} = $id if defined $id;
3713     return $self->{CALLED_FOR};
3714 }
3715
3716 #-> sub CPAN::Distribution::safe_chdir ;
3717 sub safe_chdir {
3718     my($self,$todir) = @_;
3719     # we die if we cannot chdir and we are debuggable
3720     Carp::confess("safe_chdir called without todir argument")
3721           unless defined $todir and length $todir;
3722     if (chdir $todir) {
3723         $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
3724             if $CPAN::DEBUG;
3725     } else {
3726         my $cwd = CPAN::anycwd();
3727         $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
3728                                qq{to todir[$todir]: $!});
3729     }
3730 }
3731
3732 #-> sub CPAN::Distribution::get ;
3733 sub get {
3734     my($self) = @_;
3735   EXCUSE: {
3736         my @e;
3737         exists $self->{'build_dir'} and push @e,
3738             "Is already unwrapped into directory $self->{'build_dir'}";
3739         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
3740     }
3741     my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
3742
3743     #
3744     # Get the file on local disk
3745     #
3746
3747     my($local_file);
3748     my($local_wanted) =
3749         File::Spec->catfile(
3750                             $CPAN::Config->{keep_source_where},
3751                             "authors",
3752                             "id",
3753                             split("/",$self->id)
3754                            );
3755
3756     $self->debug("Doing localize") if $CPAN::DEBUG;
3757     unless ($local_file =
3758             CPAN::FTP->localize("authors/id/$self->{ID}",
3759                                 $local_wanted)) {
3760         my $note = "";
3761         if ($CPAN::Index::DATE_OF_02) {
3762             $note = "Note: Current database in memory was generated ".
3763                 "on $CPAN::Index::DATE_OF_02\n";
3764         }
3765         $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
3766     }
3767     $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
3768     $self->{localfile} = $local_file;
3769     return if $CPAN::Signal;
3770
3771     #
3772     # Check integrity
3773     #
3774     if ($CPAN::META->has_inst("Digest::MD5")) {
3775         $self->debug("Digest::MD5 is installed, verifying");
3776         $self->verifyMD5;
3777     } else {
3778         $self->debug("Digest::MD5 is NOT installed");
3779     }
3780     return if $CPAN::Signal;
3781
3782     #
3783     # Create a clean room and go there
3784     #
3785     $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
3786     my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
3787     $self->safe_chdir($builddir);
3788     $self->debug("Removing tmp") if $CPAN::DEBUG;
3789     File::Path::rmtree("tmp");
3790     mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
3791     if ($CPAN::Signal){
3792         $self->safe_chdir($sub_wd);
3793         return;
3794     }
3795     $self->safe_chdir("tmp");
3796
3797     #
3798     # Unpack the goods
3799     #
3800     if ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)(?!\n)\Z/i){
3801         $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
3802         $self->untar_me($local_file);
3803     } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
3804         $self->unzip_me($local_file);
3805     } elsif ( $local_file =~ /\.pm\.(gz|Z)(?!\n)\Z/) {
3806         $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
3807         $self->pm2dir_me($local_file);
3808     } else {
3809         $self->{archived} = "NO";
3810         $self->safe_chdir($sub_wd);
3811         return;
3812     }
3813
3814     # we are still in the tmp directory!
3815     # Let's check if the package has its own directory.
3816     my $dh = DirHandle->new(File::Spec->curdir)
3817         or Carp::croak("Couldn't opendir .: $!");
3818     my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
3819     $dh->close;
3820     my ($distdir,$packagedir);
3821     if (@readdir == 1 && -d $readdir[0]) {
3822         $distdir = $readdir[0];
3823         $packagedir = File::Spec->catdir($builddir,$distdir);
3824         $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
3825             if $CPAN::DEBUG;
3826         -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
3827                                                     "$packagedir\n");
3828         File::Path::rmtree($packagedir);
3829         rename($distdir,$packagedir) or
3830             Carp::confess("Couldn't rename $distdir to $packagedir: $!");
3831         $self->debug(sprintf("renamed distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
3832                              $distdir,
3833                              $packagedir,
3834                              -e $packagedir,
3835                              -d $packagedir,
3836                             )) if $CPAN::DEBUG;
3837     } else {
3838         my $userid = $self->cpan_userid;
3839         unless ($userid) {
3840             CPAN->debug("no userid? self[$self]");
3841             $userid = "anon";
3842         }
3843         my $pragmatic_dir = $userid . '000';
3844         $pragmatic_dir =~ s/\W_//g;
3845         $pragmatic_dir++ while -d "../$pragmatic_dir";
3846         $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
3847         $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
3848         File::Path::mkpath($packagedir);
3849         my($f);
3850         for $f (@readdir) { # is already without "." and ".."
3851             my $to = File::Spec->catdir($packagedir,$f);
3852             rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
3853         }
3854     }
3855     if ($CPAN::Signal){
3856         $self->safe_chdir($sub_wd);
3857         return;
3858     }
3859
3860     $self->{'build_dir'} = $packagedir;
3861     $self->safe_chdir(File::Spec->updir);
3862     File::Path::rmtree("tmp");
3863
3864     my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
3865     my($mpl_exists) = -f $mpl;
3866     unless ($mpl_exists) {
3867         # NFS has been reported to have racing problems after the
3868         # renaming of a directory in some environments.
3869         # This trick helps.
3870         sleep 1;
3871         my $mpldh = DirHandle->new($packagedir)
3872             or Carp::croak("Couldn't opendir $packagedir: $!");
3873         $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
3874         $mpldh->close;
3875     }
3876     unless ($mpl_exists) {
3877         $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
3878                              $mpl,
3879                              CPAN::anycwd(),
3880                             )) if $CPAN::DEBUG;
3881         my($configure) = File::Spec->catfile($packagedir,"Configure");
3882         if (-f $configure) {
3883             # do we have anything to do?
3884             $self->{'configure'} = $configure;
3885         } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
3886             $CPAN::Frontend->myprint(qq{
3887 Package comes with a Makefile and without a Makefile.PL.
3888 We\'ll try to build it with that Makefile then.
3889 });
3890             $self->{writemakefile} = "YES";
3891             sleep 2;
3892         } else {
3893             my $cf = $self->called_for || "unknown";
3894             if ($cf =~ m|/|) {
3895                 $cf =~ s|.*/||;
3896                 $cf =~ s|\W.*||;
3897             }
3898             $cf =~ s|[/\\:]||g; # risk of filesystem damage
3899             $cf = "unknown" unless length($cf);
3900             $CPAN::Frontend->myprint(qq{Package seems to come without Makefile.PL.
3901   (The test -f "$mpl" returned false.)
3902   Writing one on our own (setting NAME to $cf)\a\n});
3903             $self->{had_no_makefile_pl}++;
3904             sleep 3;
3905
3906             # Writing our own Makefile.PL
3907
3908             my $fh = FileHandle->new;
3909             $fh->open(">$mpl")
3910                 or Carp::croak("Could not open >$mpl: $!");
3911             $fh->print(
3912 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
3913 # because there was no Makefile.PL supplied.
3914 # Autogenerated on: }.scalar localtime().qq{
3915
3916 use ExtUtils::MakeMaker;
3917 WriteMakefile(NAME => q[$cf]);
3918
3919 });
3920             $fh->close;
3921         }
3922     }
3923
3924     return $self;
3925 }
3926
3927 # CPAN::Distribution::untar_me ;
3928 sub untar_me {
3929     my($self,$local_file) = @_;
3930     $self->{archived} = "tar";
3931     if (CPAN::Tarzip->untar($local_file)) {
3932         $self->{unwrapped} = "YES";
3933     } else {
3934         $self->{unwrapped} = "NO";
3935     }
3936 }
3937
3938 # CPAN::Distribution::unzip_me ;
3939 sub unzip_me {
3940     my($self,$local_file) = @_;
3941     $self->{archived} = "zip";
3942     if (CPAN::Tarzip->unzip($local_file)) {
3943         $self->{unwrapped} = "YES";
3944     } else {
3945         $self->{unwrapped} = "NO";
3946     }
3947     return;
3948 }
3949
3950 sub pm2dir_me {
3951     my($self,$local_file) = @_;
3952     $self->{archived} = "pm";
3953     my $to = File::Basename::basename($local_file);
3954     $to =~ s/\.(gz|Z)(?!\n)\Z//;
3955     if (CPAN::Tarzip->gunzip($local_file,$to)) {
3956         $self->{unwrapped} = "YES";
3957     } else {
3958         $self->{unwrapped} = "NO";
3959     }
3960 }
3961
3962 #-> sub CPAN::Distribution::new ;
3963 sub new {
3964     my($class,%att) = @_;
3965
3966     # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
3967
3968     my $this = { %att };
3969     return bless $this, $class;
3970 }
3971
3972 #-> sub CPAN::Distribution::look ;
3973 sub look {
3974     my($self) = @_;
3975
3976     if ($^O eq 'MacOS') {
3977       $self->Mac::BuildTools::look;
3978       return;
3979     }
3980
3981     if (  $CPAN::Config->{'shell'} ) {
3982         $CPAN::Frontend->myprint(qq{
3983 Trying to open a subshell in the build directory...
3984 });
3985     } else {
3986         $CPAN::Frontend->myprint(qq{
3987 Your configuration does not define a value for subshells.
3988 Please define it with "o conf shell <your shell>"
3989 });
3990         return;
3991     }
3992     my $dist = $self->id;
3993     my $dir;
3994     unless ($dir = $self->dir) {
3995         $self->get;
3996     }
3997     unless ($dir ||= $self->dir) {
3998         $CPAN::Frontend->mywarn(qq{
3999 Could not determine which directory to use for looking at $dist.
4000 });
4001         return;
4002     }
4003     my $pwd  = CPAN::anycwd();
4004     $self->safe_chdir($dir);
4005     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4006     system($CPAN::Config->{'shell'}) == 0
4007         or $CPAN::Frontend->mydie("Subprocess shell error");
4008     $self->safe_chdir($pwd);
4009 }
4010
4011 # CPAN::Distribution::cvs_import ;
4012 sub cvs_import {
4013     my($self) = @_;
4014     $self->get;
4015     my $dir = $self->dir;
4016
4017     my $package = $self->called_for;
4018     my $module = $CPAN::META->instance('CPAN::Module', $package);
4019     my $version = $module->cpan_version;
4020
4021     my $userid = $self->cpan_userid;
4022
4023     my $cvs_dir = (split '/', $dir)[-1];
4024     $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
4025     my $cvs_root =
4026       $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
4027     my $cvs_site_perl =
4028       $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
4029     if ($cvs_site_perl) {
4030         $cvs_dir = "$cvs_site_perl/$cvs_dir";
4031     }
4032     my $cvs_log = qq{"imported $package $version sources"};
4033     $version =~ s/\./_/g;
4034     my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
4035                "$cvs_dir", $userid, "v$version");
4036
4037     my $pwd  = CPAN::anycwd();
4038     chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
4039
4040     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4041
4042     $CPAN::Frontend->myprint(qq{@cmd\n});
4043     system(@cmd) == 0 or
4044         $CPAN::Frontend->mydie("cvs import failed");
4045     chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
4046 }
4047
4048 #-> sub CPAN::Distribution::readme ;
4049 sub readme {
4050     my($self) = @_;
4051     my($dist) = $self->id;
4052     my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
4053     $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
4054     my($local_file);
4055     my($local_wanted) =
4056          File::Spec->catfile(
4057                              $CPAN::Config->{keep_source_where},
4058                              "authors",
4059                              "id",
4060                              split("/","$sans.readme"),
4061                             );
4062     $self->debug("Doing localize") if $CPAN::DEBUG;
4063     $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
4064                                       $local_wanted)
4065         or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
4066
4067     if ($^O eq 'MacOS') {
4068         Mac::BuildTools::launch_file($local_file);
4069         return;
4070     }
4071
4072     my $fh_pager = FileHandle->new;
4073     local($SIG{PIPE}) = "IGNORE";
4074     $fh_pager->open("|$CPAN::Config->{'pager'}")
4075         or die "Could not open pager $CPAN::Config->{'pager'}: $!";
4076     my $fh_readme = FileHandle->new;
4077     $fh_readme->open($local_file)
4078         or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
4079     $CPAN::Frontend->myprint(qq{
4080 Displaying file
4081   $local_file
4082 with pager "$CPAN::Config->{'pager'}"
4083 });
4084     sleep 2;
4085     $fh_pager->print(<$fh_readme>);
4086 }
4087
4088 #-> sub CPAN::Distribution::verifyMD5 ;
4089 sub verifyMD5 {
4090     my($self) = @_;
4091   EXCUSE: {
4092         my @e;
4093         $self->{MD5_STATUS} ||= "";
4094         $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
4095         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
4096     }
4097     my($lc_want,$lc_file,@local,$basename);
4098     @local = split("/",$self->id);
4099     pop @local;
4100     push @local, "CHECKSUMS";
4101     $lc_want =
4102         File::Spec->catfile($CPAN::Config->{keep_source_where},
4103                             "authors", "id", @local);
4104     local($") = "/";
4105     if (
4106         -s $lc_want
4107         &&
4108         $self->MD5_check_file($lc_want)
4109        ) {
4110         return $self->{MD5_STATUS} = "OK";
4111     }
4112     $lc_file = CPAN::FTP->localize("authors/id/@local",
4113                                    $lc_want,1);
4114     unless ($lc_file) {
4115         $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
4116         $local[-1] .= ".gz";
4117         $lc_file = CPAN::FTP->localize("authors/id/@local",
4118                                        "$lc_want.gz",1);
4119         if ($lc_file) {
4120             $lc_file =~ s/\.gz(?!\n)\Z//;
4121             CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
4122         } else {
4123             return;
4124         }
4125     }
4126     $self->MD5_check_file($lc_file);
4127 }
4128
4129 #-> sub CPAN::Distribution::MD5_check_file ;
4130 sub MD5_check_file {
4131     my($self,$chk_file) = @_;
4132     my($cksum,$file,$basename);
4133     $file = $self->{localfile};
4134     $basename = File::Basename::basename($file);
4135     my $fh = FileHandle->new;
4136     if (open $fh, $chk_file){
4137         local($/);
4138         my $eval = <$fh>;
4139         $eval =~ s/\015?\012/\n/g;
4140         close $fh;
4141         my($comp) = Safe->new();
4142         $cksum = $comp->reval($eval);
4143         if ($@) {
4144             rename $chk_file, "$chk_file.bad";
4145             Carp::confess($@) if $@;
4146         }
4147     } else {
4148         Carp::carp "Could not open $chk_file for reading";
4149     }
4150
4151     if (exists $cksum->{$basename}{md5}) {
4152         $self->debug("Found checksum for $basename:" .
4153                      "$cksum->{$basename}{md5}\n") if $CPAN::DEBUG;
4154
4155         open($fh, $file);
4156         binmode $fh;
4157         my $eq = $self->eq_MD5($fh,$cksum->{$basename}{'md5'});
4158         $fh->close;
4159         $fh = CPAN::Tarzip->TIEHANDLE($file);
4160
4161         unless ($eq) {
4162           # had to inline it, when I tied it, the tiedness got lost on
4163           # the call to eq_MD5. (Jan 1998)
4164           my $md5 = Digest::MD5->new;
4165           my($data,$ref);
4166           $ref = \$data;
4167           while ($fh->READ($ref, 4096) > 0){
4168             $md5->add($data);
4169           }
4170           my $hexdigest = $md5->hexdigest;
4171           $eq += $hexdigest eq $cksum->{$basename}{'md5-ungz'};
4172         }
4173
4174         if ($eq) {
4175           $CPAN::Frontend->myprint("Checksum for $file ok\n");
4176           return $self->{MD5_STATUS} = "OK";
4177         } else {
4178             $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
4179                                      qq{distribution file. }.
4180                                      qq{Please investigate.\n\n}.
4181                                      $self->as_string,
4182                                      $CPAN::META->instance(
4183                                                            'CPAN::Author',
4184                                                            $self->cpan_userid
4185                                                           )->as_string);
4186
4187             my $wrap = qq{I\'d recommend removing $file. Its MD5
4188 checksum is incorrect. Maybe you have configured your 'urllist' with
4189 a bad URL. Please check this array with 'o conf urllist', and
4190 retry.};
4191
4192             $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
4193
4194             # former versions just returned here but this seems a
4195             # serious threat that deserves a die
4196
4197             # $CPAN::Frontend->myprint("\n\n");
4198             # sleep 3;
4199             # return;
4200         }
4201         # close $fh if fileno($fh);
4202     } else {
4203         $self->{MD5_STATUS} ||= "";
4204         if ($self->{MD5_STATUS} eq "NIL") {
4205             $CPAN::Frontend->mywarn(qq{
4206 Warning: No md5 checksum for $basename in $chk_file.
4207
4208 The cause for this may be that the file is very new and the checksum
4209 has not yet been calculated, but it may also be that something is
4210 going awry right now.
4211 });
4212             my $answer = ExtUtils::MakeMaker::prompt("Proceed?", "yes");
4213             $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.");
4214         }
4215         $self->{MD5_STATUS} = "NIL";
4216         return;
4217     }
4218 }
4219
4220 #-> sub CPAN::Distribution::eq_MD5 ;
4221 sub eq_MD5 {
4222     my($self,$fh,$expectMD5) = @_;
4223     my $md5 = Digest::MD5->new;
4224     my($data);
4225     while (read($fh, $data, 4096)){
4226       $md5->add($data);
4227     }
4228     # $md5->addfile($fh);
4229     my $hexdigest = $md5->hexdigest;
4230     # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
4231     $hexdigest eq $expectMD5;
4232 }
4233
4234 #-> sub CPAN::Distribution::force ;
4235
4236 # Both modules and distributions know if "force" is in effect by
4237 # autoinspection, not by inspecting a global variable. One of the
4238 # reason why this was chosen to work that way was the treatment of
4239 # dependencies. They should not autpomatically inherit the force
4240 # status. But this has the downside that ^C and die() will return to
4241 # the prompt but will not be able to reset the force_update
4242 # attributes. We try to correct for it currently in the read_metadata
4243 # routine, and immediately before we check for a Signal. I hope this
4244 # works out in one of v1.57_53ff
4245
4246 sub force {
4247   my($self, $method) = @_;
4248   for my $att (qw(
4249   MD5_STATUS archived build_dir localfile make install unwrapped
4250   writemakefile
4251  )) {
4252     delete $self->{$att};
4253   }
4254   if ($method && $method eq "install") {
4255     $self->{"force_update"}++; # name should probably have been force_install
4256   }
4257 }
4258
4259 #-> sub CPAN::Distribution::unforce ;
4260 sub unforce {
4261   my($self) = @_;
4262   delete $self->{'force_update'};
4263 }
4264
4265 #-> sub CPAN::Distribution::isa_perl ;
4266 sub isa_perl {
4267   my($self) = @_;
4268   my $file = File::Basename::basename($self->id);
4269   if ($file =~ m{ ^ perl
4270                   -?
4271                   (5)
4272                   ([._-])
4273                   (
4274                    \d{3}(_[0-4][0-9])?
4275                    |
4276                    \d*[24680]\.\d+
4277                   )
4278                   \.tar[._-]gz
4279                   (?!\n)\Z
4280                 }xs){
4281     return "$1.$3";
4282   } elsif ($self->cpan_comment
4283            &&
4284            $self->cpan_comment =~ /isa_perl\(.+?\)/){
4285     return $1;
4286   }
4287 }
4288
4289 #-> sub CPAN::Distribution::perl ;
4290 sub perl {
4291     my($self) = @_;
4292     my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
4293     my $pwd  = CPAN::anycwd();
4294     my $candidate = File::Spec->catfile($pwd,$^X);
4295     $perl ||= $candidate if MM->maybe_command($candidate);
4296     unless ($perl) {
4297         my ($component,$perl_name);
4298       DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
4299             PATH_COMPONENT: foreach $component (File::Spec->path(),
4300                                                 $Config::Config{'binexp'}) {
4301                   next unless defined($component) && $component;
4302                   my($abs) = File::Spec->catfile($component,$perl_name);
4303                   if (MM->maybe_command($abs)) {
4304                       $perl = $abs;
4305                       last DIST_PERLNAME;
4306                   }
4307               }
4308           }
4309     }
4310     $perl;
4311 }
4312
4313 #-> sub CPAN::Distribution::make ;
4314 sub make {
4315     my($self) = @_;
4316     $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id);
4317     # Emergency brake if they said install Pippi and get newest perl
4318     if ($self->isa_perl) {
4319       if (
4320           $self->called_for ne $self->id &&
4321           ! $self->{force_update}
4322          ) {
4323         # if we die here, we break bundles
4324         $CPAN::Frontend->mywarn(sprintf qq{
4325 The most recent version "%s" of the module "%s"
4326 comes with the current version of perl (%s).
4327 I\'ll build that only if you ask for something like
4328     force install %s
4329 or
4330     install %s
4331 },
4332                                $CPAN::META->instance(
4333                                                      'CPAN::Module',
4334                                                      $self->called_for
4335                                                     )->cpan_version,
4336                                $self->called_for,
4337                                $self->isa_perl,
4338                                $self->called_for,
4339                                $self->id);
4340         sleep 5; return;
4341       }
4342     }
4343     $self->get;
4344   EXCUSE: {
4345         my @e;
4346         $self->{archived} eq "NO" and push @e,
4347         "Is neither a tar nor a zip archive.";
4348
4349         $self->{unwrapped} eq "NO" and push @e,
4350         "had problems unarchiving. Please build manually";
4351
4352         exists $self->{writemakefile} &&
4353             $self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e,
4354                 $1 || "Had some problem writing Makefile";
4355
4356         defined $self->{'make'} and push @e,
4357             "Has already been processed within this session";
4358
4359         exists $self->{later} and length($self->{later}) and
4360             push @e, $self->{later};
4361
4362         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
4363     }
4364     $CPAN::Frontend->myprint("\n  CPAN.pm: Going to build ".$self->id."\n\n");
4365     my $builddir = $self->dir;
4366     chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
4367     $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
4368
4369     if ($^O eq 'MacOS') {
4370         Mac::BuildTools::make($self);
4371         return;
4372     }
4373
4374     my $system;
4375     if ($self->{'configure'}) {
4376       $system = $self->{'configure'};
4377     } else {
4378         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
4379         my $switch = "";
4380 # This needs a handler that can be turned on or off:
4381 #       $switch = "-MExtUtils::MakeMaker ".
4382 #           "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
4383 #           if $] > 5.00310;
4384         $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
4385     }
4386     unless (exists $self->{writemakefile}) {
4387         local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
4388         my($ret,$pid);
4389         $@ = "";
4390         if ($CPAN::Config->{inactivity_timeout}) {
4391             eval {
4392                 alarm $CPAN::Config->{inactivity_timeout};
4393                 local $SIG{CHLD}; # = sub { wait };
4394                 if (defined($pid = fork)) {
4395                     if ($pid) { #parent
4396                         # wait;
4397                         waitpid $pid, 0;
4398                     } else {    #child
4399                       # note, this exec isn't necessary if
4400                       # inactivity_timeout is 0. On the Mac I'd
4401                       # suggest, we set it always to 0.
4402                       exec $system;
4403                     }
4404                 } else {
4405                     $CPAN::Frontend->myprint("Cannot fork: $!");
4406                     return;
4407                 }
4408             };
4409             alarm 0;
4410             if ($@){
4411                 kill 9, $pid;
4412                 waitpid $pid, 0;
4413                 $CPAN::Frontend->myprint($@);
4414                 $self->{writemakefile} = "NO $@";
4415                 $@ = "";
4416                 return;
4417             }
4418         } else {
4419           $ret = system($system);
4420           if ($ret != 0) {
4421             $self->{writemakefile} = "NO Makefile.PL returned status $ret";
4422             return;
4423           }
4424         }
4425         if (-f "Makefile") {
4426           $self->{writemakefile} = "YES";
4427           delete $self->{make_clean}; # if cleaned before, enable next
4428         } else {
4429           $self->{writemakefile} =
4430               qq{NO Makefile.PL refused to write a Makefile.};
4431           # It's probably worth it to record the reason, so let's retry
4432           # local $/;
4433           # my $fh = IO::File->new("$system |"); # STDERR? STDIN?
4434           # $self->{writemakefile} .= <$fh>;
4435         }
4436     }
4437     if ($CPAN::Signal){
4438       delete $self->{force_update};
4439       return;
4440     }
4441     if (my @prereq = $self->unsat_prereq){
4442       return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4443     }
4444     $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
4445     if (system($system) == 0) {
4446          $CPAN::Frontend->myprint("  $system -- OK\n");
4447          $self->{'make'} = "YES";
4448     } else {
4449          $self->{writemakefile} ||= "YES";
4450          $self->{'make'} = "NO";
4451          $CPAN::Frontend->myprint("  $system -- NOT OK\n");
4452     }
4453 }
4454
4455 sub follow_prereqs {
4456     my($self) = shift;
4457     my(@prereq) = @_;
4458     my $id = $self->id;
4459     $CPAN::Frontend->myprint("---- Unsatisfied dependencies detected ".
4460                              "during [$id] -----\n");
4461
4462     for my $p (@prereq) {
4463         $CPAN::Frontend->myprint("    $p\n");
4464     }
4465     my $follow = 0;
4466     if ($CPAN::Config->{prerequisites_policy} eq "follow") {
4467         $follow = 1;
4468     } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
4469         require ExtUtils::MakeMaker;
4470         my $answer = ExtUtils::MakeMaker::prompt(
4471 "Shall I follow them and prepend them to the queue
4472 of modules we are processing right now?", "yes");
4473         $follow = $answer =~ /^\s*y/i;
4474     } else {
4475         local($") = ", ";
4476         $CPAN::Frontend->
4477             myprint("  Ignoring dependencies on modules @prereq\n");
4478     }
4479     if ($follow) {
4480         # color them as dirty
4481         for my $p (@prereq) {
4482             CPAN::Shell->expandany($p)->color_cmd_tmps(0,1);
4483         }
4484         CPAN::Queue->jumpqueue(@prereq,$id); # queue them and requeue yourself
4485         $self->{later} = "Delayed until after prerequisites";
4486         return 1; # signal success to the queuerunner
4487     }
4488 }
4489
4490 #-> sub CPAN::Distribution::unsat_prereq ;
4491 sub unsat_prereq {
4492     my($self) = @_;
4493     my $prereq_pm = $self->prereq_pm or return;
4494     my(@need);
4495   NEED: while (my($need_module, $need_version) = each %$prereq_pm) {
4496         my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
4497         # we were too demanding:
4498         next if $nmo->uptodate;
4499
4500         # if they have not specified a version, we accept any installed one
4501         if (not defined $need_version or
4502            $need_version == 0 or
4503            $need_version eq "undef") {
4504             next if defined $nmo->inst_file;
4505         }
4506
4507         # We only want to install prereqs if either they're not installed
4508         # or if the installed version is too old. We cannot omit this
4509         # check, because if 'force' is in effect, nobody else will check.
4510         {
4511             local($^W) = 0;
4512             if (
4513                 defined $nmo->inst_file &&
4514                 ! CPAN::Version->vgt($need_version, $nmo->inst_version)
4515                ){
4516                 CPAN->debug(sprintf "id[%s]inst_file[%s]inst_version[%s]need_version[%s]",
4517                             $nmo->id,
4518                             $nmo->inst_file,
4519                             $nmo->inst_version,
4520                             CPAN::Version->readable($need_version)
4521                            );
4522                 next NEED;
4523             }
4524         }
4525
4526         if ($self->{sponsored_mods}{$need_module}++){
4527             # We have already sponsored it and for some reason it's still
4528             # not available. So we do nothing. Or what should we do?
4529             # if we push it again, we have a potential infinite loop
4530             next;
4531         }
4532         push @need, $need_module;
4533     }
4534     @need;
4535 }
4536
4537 #-> sub CPAN::Distribution::prereq_pm ;
4538 sub prereq_pm {
4539   my($self) = @_;
4540   return $self->{prereq_pm} if
4541       exists $self->{prereq_pm_detected} && $self->{prereq_pm_detected};
4542   return unless $self->{writemakefile}; # no need to have succeeded
4543                                         # but we must have run it
4544   my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
4545   my $makefile = File::Spec->catfile($build_dir,"Makefile");
4546   my(%p) = ();
4547   my $fh;
4548   if (-f $makefile
4549       and
4550       $fh = FileHandle->new("<$makefile\0")) {
4551
4552       local($/) = "\n";
4553
4554       #  A.Speer @p -> %p, where %p is $p{Module::Name}=Required_Version
4555       while (<$fh>) {
4556           last if /MakeMaker post_initialize section/;
4557           my($p) = m{^[\#]
4558                  \s+PREREQ_PM\s+=>\s+(.+)
4559                  }x;
4560           next unless $p;
4561           # warn "Found prereq expr[$p]";
4562
4563           #  Regexp modified by A.Speer to remember actual version of file
4564           #  PREREQ_PM hash key wants, then add to
4565           while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
4566               # In case a prereq is mentioned twice, complain.
4567               if ( defined $p{$1} ) {
4568                   warn "Warning: PREREQ_PM mentions $1 more than once, last mention wins";
4569               }
4570               $p{$1} = $2;
4571           }
4572           last;
4573       }
4574   }
4575   $self->{prereq_pm_detected}++;
4576   return $self->{prereq_pm} = \%p;
4577 }
4578
4579 #-> sub CPAN::Distribution::test ;
4580 sub test {
4581     my($self) = @_;
4582     $self->make;
4583     if ($CPAN::Signal){
4584       delete $self->{force_update};
4585       return;
4586     }
4587     $CPAN::Frontend->myprint("Running make test\n");
4588     if (my @prereq = $self->unsat_prereq){
4589       return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4590     }
4591   EXCUSE: {
4592         my @e;
4593         exists $self->{make} or exists $self->{later} or push @e,
4594         "Make had some problems, maybe interrupted? Won't test";
4595
4596         exists $self->{'make'} and
4597             $self->{'make'} eq 'NO' and
4598                 push @e, "Can't test without successful make";
4599
4600         exists $self->{build_dir} or push @e, "Has no own directory";
4601         $self->{badtestcnt} ||= 0;
4602         $self->{badtestcnt} > 0 and
4603             push @e, "Won't repeat unsuccessful test during this command";
4604
4605         exists $self->{later} and length($self->{later}) and
4606             push @e, $self->{later};
4607
4608         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
4609     }
4610     chdir $self->{'build_dir'} or
4611         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4612     $self->debug("Changed directory to $self->{'build_dir'}")
4613         if $CPAN::DEBUG;
4614
4615     if ($^O eq 'MacOS') {
4616         Mac::BuildTools::make_test($self);
4617         return;
4618     }
4619
4620     my $system = join " ", $CPAN::Config->{'make'}, "test";
4621     if (system($system) == 0) {
4622          $CPAN::Frontend->myprint("  $system -- OK\n");
4623          $self->{make_test} = "YES";
4624     } else {
4625          $self->{make_test} = "NO";
4626          $self->{badtestcnt}++;
4627          $CPAN::Frontend->myprint("  $system -- NOT OK\n");
4628     }
4629 }
4630
4631 #-> sub CPAN::Distribution::clean ;
4632 sub clean {
4633     my($self) = @_;
4634     $CPAN::Frontend->myprint("Running make clean\n");
4635   EXCUSE: {
4636         my @e;
4637         exists $self->{make_clean} and $self->{make_clean} eq "YES" and
4638             push @e, "make clean already called once";
4639         exists $self->{build_dir} or push @e, "Has no own directory";
4640         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
4641     }
4642     chdir $self->{'build_dir'} or
4643         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4644     $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
4645
4646     if ($^O eq 'MacOS') {
4647         Mac::BuildTools::make_clean($self);
4648         return;
4649     }
4650
4651     my $system = join " ", $CPAN::Config->{'make'}, "clean";
4652     if (system($system) == 0) {
4653       $CPAN::Frontend->myprint("  $system -- OK\n");
4654
4655       # $self->force;
4656
4657       # Jost Krieger pointed out that this "force" was wrong because
4658       # it has the effect that the next "install" on this distribution
4659       # will untar everything again. Instead we should bring the
4660       # object's state back to where it is after untarring.
4661
4662       delete $self->{force_update};
4663       delete $self->{install};
4664       delete $self->{writemakefile};
4665       delete $self->{make};
4666       delete $self->{make_test}; # no matter if yes or no, tests must be redone
4667       $self->{make_clean} = "YES";
4668
4669     } else {
4670       # Hmmm, what to do if make clean failed?
4671
4672       $CPAN::Frontend->myprint(qq{  $system -- NOT OK
4673
4674 make clean did not succeed, marking directory as unusable for further work.
4675 });
4676       $self->force("make"); # so that this directory won't be used again
4677
4678     }
4679 }
4680
4681 #-> sub CPAN::Distribution::install ;
4682 sub install {
4683     my($self) = @_;
4684     $self->test;
4685     if ($CPAN::Signal){
4686       delete $self->{force_update};
4687       return;
4688     }
4689     $CPAN::Frontend->myprint("Running make install\n");
4690   EXCUSE: {
4691         my @e;
4692         exists $self->{build_dir} or push @e, "Has no own directory";
4693
4694         exists $self->{make} or exists $self->{later} or push @e,
4695         "Make had some problems, maybe interrupted? Won't install";
4696
4697         exists $self->{'make'} and
4698             $self->{'make'} eq 'NO' and
4699                 push @e, "make had returned bad status, install seems impossible";
4700
4701         push @e, "make test had returned bad status, ".
4702             "won't install without force"
4703             if exists $self->{'make_test'} and
4704             $self->{'make_test'} eq 'NO' and
4705             ! $self->{'force_update'};
4706
4707         exists $self->{'install'} and push @e,
4708         $self->{'install'} eq "YES" ?
4709             "Already done" : "Already tried without success";
4710
4711         exists $self->{later} and length($self->{later}) and
4712             push @e, $self->{later};
4713
4714         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
4715     }
4716     chdir $self->{'build_dir'} or
4717         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4718     $self->debug("Changed directory to $self->{'build_dir'}")
4719         if $CPAN::DEBUG;
4720
4721     if ($^O eq 'MacOS') {
4722         Mac::BuildTools::make_install($self);
4723         return;
4724     }
4725
4726     my $system = join(" ", $CPAN::Config->{'make'},
4727                       "install", $CPAN::Config->{make_install_arg});
4728     my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 ";
4729     my($pipe) = FileHandle->new("$system $stderr |");
4730     my($makeout) = "";
4731     while (<$pipe>){
4732         $CPAN::Frontend->myprint($_);
4733         $makeout .= $_;
4734     }
4735     $pipe->close;
4736     if ($?==0) {
4737          $CPAN::Frontend->myprint("  $system -- OK\n");
4738          return $self->{'install'} = "YES";
4739     } else {
4740          $self->{'install'} = "NO";
4741          $CPAN::Frontend->myprint("  $system -- NOT OK\n");
4742          if ($makeout =~ /permission/s && $> > 0) {
4743              $CPAN::Frontend->myprint(qq{    You may have to su }.
4744                                       qq{to root to install the package\n});
4745          }
4746     }
4747     delete $self->{force_update};
4748 }
4749
4750 #-> sub CPAN::Distribution::dir ;
4751 sub dir {
4752     shift->{'build_dir'};
4753 }
4754
4755 package CPAN::Bundle;
4756
4757 sub undelay {
4758     my $self = shift;
4759     delete $self->{later};
4760     for my $c ( $self->contains ) {
4761         my $obj = CPAN::Shell->expandany($c) or next;
4762         $obj->undelay;
4763     }
4764 }
4765
4766 #-> sub CPAN::Bundle::color_cmd_tmps ;
4767 sub color_cmd_tmps {
4768     my($self) = shift;
4769     my($depth) = shift || 0;
4770     my($color) = shift || 0;
4771     # a module needs to recurse to its cpan_file, a distribution needs
4772     # to recurse into its prereq_pms, a bundle needs to recurse into its modules
4773
4774     return if exists $self->{incommandcolor}
4775         && $self->{incommandcolor}==$color;
4776     $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
4777                                    "color_cmd_tmps depth[%s] self[%s] id[%s]",
4778                                    $depth,
4779                                    $self,
4780                                    $self->id
4781                                   )) if $depth>=100;
4782     ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
4783
4784     for my $c ( $self->contains ) {
4785         my $obj = CPAN::Shell->expandany($c) or next;
4786         CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
4787         $obj->color_cmd_tmps($depth+1,$color);
4788     }
4789     if ($color==0) {
4790         delete $self->{badtestcnt};
4791     }
4792     $self->{incommandcolor} = $color;
4793 }
4794
4795 #-> sub CPAN::Bundle::as_string ;
4796 sub as_string {
4797     my($self) = @_;
4798     $self->contains;
4799     # following line must be "=", not "||=" because we have a moving target
4800     $self->{INST_VERSION} = $self->inst_version;
4801     return $self->SUPER::as_string;
4802 }
4803
4804 #-> sub CPAN::Bundle::contains ;
4805 sub contains {
4806     my($self) = @_;
4807     my($inst_file) = $self->inst_file || "";
4808     my($id) = $self->id;
4809     $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
4810     unless ($inst_file) {
4811         # Try to get at it in the cpan directory
4812         $self->debug("no inst_file") if $CPAN::DEBUG;
4813         my $cpan_file;
4814         $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
4815               $cpan_file = $self->cpan_file;
4816         if ($cpan_file eq "N/A") {
4817             $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
4818   Maybe stale symlink? Maybe removed during session? Giving up.\n");
4819         }
4820         my $dist = $CPAN::META->instance('CPAN::Distribution',
4821                                          $self->cpan_file);
4822         $dist->get;
4823         $self->debug($dist->as_string) if $CPAN::DEBUG;
4824         my($todir) = $CPAN::Config->{'cpan_home'};
4825         my(@me,$from,$to,$me);
4826         @me = split /::/, $self->id;
4827         $me[-1] .= ".pm";
4828         $me = File::Spec->catfile(@me);
4829         $from = $self->find_bundle_file($dist->{'build_dir'},$me);
4830         $to = File::Spec->catfile($todir,$me);
4831         File::Path::mkpath(File::Basename::dirname($to));
4832         File::Copy::copy($from, $to)
4833               or Carp::confess("Couldn't copy $from to $to: $!");
4834         $inst_file = $to;
4835     }
4836     my @result;
4837     my $fh = FileHandle->new;
4838     local $/ = "\n";
4839     open($fh,$inst_file) or die "Could not open '$inst_file': $!";
4840     my $in_cont = 0;
4841     $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
4842     while (<$fh>) {
4843         $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
4844             m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
4845         next unless $in_cont;
4846         next if /^=/;
4847         s/\#.*//;
4848         next if /^\s+$/;
4849         chomp;
4850         push @result, (split " ", $_, 2)[0];
4851     }
4852     close $fh;
4853     delete $self->{STATUS};
4854     $self->{CONTAINS} = \@result;
4855     $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
4856     unless (@result) {
4857         $CPAN::Frontend->mywarn(qq{
4858 The bundle file "$inst_file" may be a broken
4859 bundlefile. It seems not to contain any bundle definition.
4860 Please check the file and if it is bogus, please delete it.
4861 Sorry for the inconvenience.
4862 });
4863     }
4864     @result;
4865 }
4866
4867 #-> sub CPAN::Bundle::find_bundle_file
4868 sub find_bundle_file {
4869     my($self,$where,$what) = @_;
4870     $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
4871 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
4872 ###    my $bu = File::Spec->catfile($where,$what);
4873 ###    return $bu if -f $bu;
4874     my $manifest = File::Spec->catfile($where,"MANIFEST");
4875     unless (-f $manifest) {
4876         require ExtUtils::Manifest;
4877         my $cwd = CPAN::anycwd();
4878         chdir $where or $CPAN::Frontend->mydie(qq{Could not chdir to "$where": $!});
4879         ExtUtils::Manifest::mkmanifest();
4880         chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
4881     }
4882     my $fh = FileHandle->new($manifest)
4883         or Carp::croak("Couldn't open $manifest: $!");
4884     local($/) = "\n";
4885     my $what2 = $what;
4886     if ($^O eq 'MacOS') {
4887       $what =~ s/^://;
4888       $what =~ tr|:|/|;
4889       $what2 =~ s/:Bundle://;
4890       $what2 =~ tr|:|/|;
4891     } else {
4892         $what2 =~ s|Bundle[/\\]||;
4893     }
4894     my $bu;
4895     while (<$fh>) {
4896         next if /^\s*\#/;
4897         my($file) = /(\S+)/;
4898         if ($file =~ m|\Q$what\E$|) {
4899             $bu = $file;
4900             # return File::Spec->catfile($where,$bu); # bad
4901             last;
4902         }
4903         # retry if she managed to
4904         # have no Bundle directory
4905         $bu = $file if $file =~ m|\Q$what2\E$|;
4906     }
4907     $bu =~ tr|/|:| if $^O eq 'MacOS';
4908     return File::Spec->catfile($where, $bu) if $bu;
4909     Carp::croak("Couldn't find a Bundle file in $where");
4910 }
4911
4912 # needs to work quite differently from Module::inst_file because of
4913 # cpan_home/Bundle/ directory and the possibility that we have
4914 # shadowing effect. As it makes no sense to take the first in @INC for
4915 # Bundles, we parse them all for $VERSION and take the newest.
4916
4917 #-> sub CPAN::Bundle::inst_file ;
4918 sub inst_file {
4919     my($self) = @_;
4920     my($inst_file);
4921     my(@me);
4922     @me = split /::/, $self->id;
4923     $me[-1] .= ".pm";
4924     my($incdir,$bestv);
4925     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
4926         my $bfile = File::Spec->catfile($incdir, @me);
4927         CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
4928         next unless -f $bfile;
4929         my $foundv = MM->parse_version($bfile);
4930         if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
4931             $self->{INST_FILE} = $bfile;
4932             $self->{INST_VERSION} = $bestv = $foundv;
4933         }
4934     }
4935     $self->{INST_FILE};
4936 }
4937
4938 #-> sub CPAN::Bundle::inst_version ;
4939 sub inst_version {
4940     my($self) = @_;
4941     $self->inst_file; # finds INST_VERSION as side effect
4942     $self->{INST_VERSION};
4943 }
4944
4945 #-> sub CPAN::Bundle::rematein ;
4946 sub rematein {
4947     my($self,$meth) = @_;
4948     $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
4949     my($id) = $self->id;
4950     Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
4951         unless $self->inst_file || $self->cpan_file;
4952     my($s,%fail);
4953     for $s ($self->contains) {
4954         my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
4955             $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
4956         if ($type eq 'CPAN::Distribution') {
4957             $CPAN::Frontend->mywarn(qq{
4958 The Bundle }.$self->id.qq{ contains
4959 explicitly a file $s.
4960 });
4961             sleep 3;
4962         }
4963         # possibly noisy action:
4964         $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
4965         my $obj = $CPAN::META->instance($type,$s);
4966         $obj->$meth();
4967         if ($obj->isa(CPAN::Bundle)
4968             &&
4969             exists $obj->{install_failed}
4970             &&
4971             ref($obj->{install_failed}) eq "HASH"
4972            ) {
4973           for (keys %{$obj->{install_failed}}) {
4974             $self->{install_failed}{$_} = undef; # propagate faiure up
4975                                                  # to me in a
4976                                                  # recursive call
4977             $fail{$s} = 1; # the bundle itself may have succeeded but
4978                            # not all children
4979           }
4980         } else {
4981           my $success;
4982           $success = $obj->can("uptodate") ? $obj->uptodate : 0;
4983           $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
4984           if ($success) {
4985             delete $self->{install_failed}{$s};
4986           } else {
4987             $fail{$s} = 1;
4988           }
4989         }
4990     }
4991
4992     # recap with less noise
4993     if ( $meth eq "install" ) {
4994         if (%fail) {
4995             require Text::Wrap;
4996             my $raw = sprintf(qq{Bundle summary:
4997 The following items in bundle %s had installation problems:},
4998                               $self->id
4999                              );
5000             $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
5001             $CPAN::Frontend->myprint("\n");
5002             my $paragraph = "";
5003             my %reported;
5004             for $s ($self->contains) {
5005               if ($fail{$s}){
5006                 $paragraph .= "$s ";
5007                 $self->{install_failed}{$s} = undef;
5008                 $reported{$s} = undef;
5009               }
5010             }
5011             my $report_propagated;
5012             for $s (sort keys %{$self->{install_failed}}) {
5013               next if exists $reported{$s};
5014               $paragraph .= "and the following items had problems
5015 during recursive bundle calls: " unless $report_propagated++;
5016               $paragraph .= "$s ";
5017             }
5018             $CPAN::Frontend->myprint(Text::Wrap::fill("  ","  ",$paragraph));
5019             $CPAN::Frontend->myprint("\n");
5020         } else {
5021             $self->{'install'} = 'YES';
5022         }
5023     }
5024 }
5025
5026 #sub CPAN::Bundle::xs_file
5027 sub xs_file {
5028     # If a bundle contains another that contains an xs_file we have
5029     # here, we just don't bother I suppose
5030     return 0;
5031 }
5032
5033 #-> sub CPAN::Bundle::force ;
5034 sub force   { shift->rematein('force',@_); }
5035 #-> sub CPAN::Bundle::get ;
5036 sub get     { shift->rematein('get',@_); }
5037 #-> sub CPAN::Bundle::make ;
5038 sub make    { shift->rematein('make',@_); }
5039 #-> sub CPAN::Bundle::test ;
5040 sub test    {
5041     my $self = shift;
5042     $self->{badtestcnt} ||= 0;
5043     $self->rematein('test',@_);
5044 }
5045 #-> sub CPAN::Bundle::install ;
5046 sub install {
5047   my $self = shift;
5048   $self->rematein('install',@_);
5049 }
5050 #-> sub CPAN::Bundle::clean ;
5051 sub clean   { shift->rematein('clean',@_); }
5052
5053 #-> sub CPAN::Bundle::uptodate ;
5054 sub uptodate {
5055     my($self) = @_;
5056     return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
5057     my $c;
5058     foreach $c ($self->contains) {
5059         my $obj = CPAN::Shell->expandany($c);
5060         return 0 unless $obj->uptodate;
5061     }
5062     return 1;
5063 }
5064
5065 #-> sub CPAN::Bundle::readme ;
5066 sub readme  {
5067     my($self) = @_;
5068     my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
5069 No File found for bundle } . $self->id . qq{\n}), return;
5070     $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
5071     $CPAN::META->instance('CPAN::Distribution',$file)->readme;
5072 }
5073
5074 package CPAN::Module;
5075
5076 # Accessors
5077 # sub cpan_userid { shift->{RO}{CPAN_USERID} }
5078 sub userid {
5079     my $self = shift;
5080     return unless exists $self->{RO}; # should never happen
5081     return $self->{RO}{CPAN_USERID} || $self->{RO}{userid};
5082 }
5083 sub description { shift->{RO}{description} }
5084
5085 sub undelay {
5086     my $self = shift;
5087     delete $self->{later};
5088     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5089         $dist->undelay;
5090     }
5091 }
5092
5093 #-> sub CPAN::Module::color_cmd_tmps ;
5094 sub color_cmd_tmps {
5095     my($self) = shift;
5096     my($depth) = shift || 0;
5097     my($color) = shift || 0;
5098     # a module needs to recurse to its cpan_file
5099
5100     return if exists $self->{incommandcolor}
5101         && $self->{incommandcolor}==$color;
5102     $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
5103                                    "color_cmd_tmps depth[%s] self[%s] id[%s]",
5104                                    $depth,
5105                                    $self,
5106                                    $self->id
5107                                   )) if $depth>=100;
5108     ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5109
5110     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5111         $dist->color_cmd_tmps($depth+1,$color);
5112     }
5113     if ($color==0) {
5114         delete $self->{badtestcnt};
5115     }
5116     $self->{incommandcolor} = $color;
5117 }
5118
5119 #-> sub CPAN::Module::as_glimpse ;
5120 sub as_glimpse {
5121     my($self) = @_;
5122     my(@m);
5123     my $class = ref($self);
5124     $class =~ s/^CPAN:://;
5125     my $color_on = "";
5126     my $color_off = "";
5127     if (
5128         $CPAN::Shell::COLOR_REGISTERED
5129         &&
5130         $CPAN::META->has_inst("Term::ANSIColor")
5131         &&
5132         $self->{RO}{description}
5133        ) {
5134         $color_on = Term::ANSIColor::color("green");
5135         $color_off = Term::ANSIColor::color("reset");
5136     }
5137     push @m, sprintf("%-15s %s%-15s%s (%s)\n",
5138                      $class,
5139                      $color_on,
5140                      $self->id,
5141                      $color_off,
5142                      $self->cpan_file);
5143     join "", @m;
5144 }
5145
5146 #-> sub CPAN::Module::as_string ;
5147 sub as_string {
5148     my($self) = @_;
5149     my(@m);
5150     CPAN->debug($self) if $CPAN::DEBUG;
5151     my $class = ref($self);
5152     $class =~ s/^CPAN:://;
5153     local($^W) = 0;
5154     push @m, $class, " id = $self->{ID}\n";
5155     my $sprintf = "    %-12s %s\n";
5156     push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
5157         if $self->description;
5158     my $sprintf2 = "    %-12s %s (%s)\n";
5159     my($userid);
5160     if ($userid = $self->cpan_userid || $self->userid){
5161         my $author;
5162         if ($author = CPAN::Shell->expand('Author',$userid)) {
5163           my $email = "";
5164           my $m; # old perls
5165           if ($m = $author->email) {
5166             $email = " <$m>";
5167           }
5168           push @m, sprintf(
5169                            $sprintf2,
5170                            'CPAN_USERID',
5171                            $userid,
5172                            $author->fullname . $email
5173                           );
5174         }
5175     }
5176     push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
5177         if $self->cpan_version;
5178     push @m, sprintf($sprintf, 'CPAN_FILE', $self->cpan_file)
5179         if $self->cpan_file;
5180     my $sprintf3 = "    %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
5181     my(%statd,%stats,%statl,%stati);
5182     @statd{qw,? i c a b R M S,} = qw,unknown idea
5183         pre-alpha alpha beta released mature standard,;
5184     @stats{qw,? m d u n,}       = qw,unknown mailing-list
5185         developer comp.lang.perl.* none,;
5186     @statl{qw,? p c + o h,}       = qw,unknown perl C C++ other hybrid,;
5187     @stati{qw,? f r O h,}         = qw,unknown functions
5188         references+ties object-oriented hybrid,;
5189     $statd{' '} = 'unknown';
5190     $stats{' '} = 'unknown';
5191     $statl{' '} = 'unknown';
5192     $stati{' '} = 'unknown';
5193     push @m, sprintf(
5194                      $sprintf3,
5195                      'DSLI_STATUS',
5196                      $self->{RO}{statd},
5197                      $self->{RO}{stats},
5198                      $self->{RO}{statl},
5199                      $self->{RO}{stati},
5200                      $statd{$self->{RO}{statd}},
5201                      $stats{$self->{RO}{stats}},
5202                      $statl{$self->{RO}{statl}},
5203                      $stati{$self->{RO}{stati}}
5204                     ) if $self->{RO}{statd};
5205     my $local_file = $self->inst_file;
5206     unless ($self->{MANPAGE}) {
5207         if ($local_file) {
5208             $self->{MANPAGE} = $self->manpage_headline($local_file);
5209         } else {
5210             # If we have already untarred it, we should look there
5211             my $dist = $CPAN::META->instance('CPAN::Distribution',
5212                                              $self->cpan_file);
5213             # warn "dist[$dist]";
5214             # mff=manifest file; mfh=manifest handle
5215             my($mff,$mfh);
5216             if (
5217                 $dist->{build_dir}
5218                 and
5219                 (-f  ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
5220                 and
5221                 $mfh = FileHandle->new($mff)
5222                ) {
5223                 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
5224                 my $lfre = $self->id; # local file RE
5225                 $lfre =~ s/::/./g;
5226                 $lfre .= "\\.pm\$";
5227                 my($lfl); # local file file
5228                 local $/ = "\n";
5229                 my(@mflines) = <$mfh>;
5230                 for (@mflines) {
5231                     s/^\s+//;
5232                     s/\s.*//s;
5233                 }
5234                 while (length($lfre)>5 and !$lfl) {
5235                     ($lfl) = grep /$lfre/, @mflines;
5236                     CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
5237                     $lfre =~ s/.+?\.//;
5238                 }
5239                 $lfl =~ s/\s.*//; # remove comments
5240                 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
5241                 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
5242                 # warn "lfl_abs[$lfl_abs]";
5243                 if (-f $lfl_abs) {
5244                     $self->{MANPAGE} = $self->manpage_headline($lfl_abs);
5245                 }
5246             }
5247         }
5248     }
5249     my($item);
5250     for $item (qw/MANPAGE/) {
5251         push @m, sprintf($sprintf, $item, $self->{$item})
5252             if exists $self->{$item};
5253     }
5254     for $item (qw/CONTAINS/) {
5255         push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
5256             if exists $self->{$item} && @{$self->{$item}};
5257     }
5258     push @m, sprintf($sprintf, 'INST_FILE',
5259                      $local_file || "(not installed)");
5260     push @m, sprintf($sprintf, 'INST_VERSION',
5261                      $self->inst_version) if $local_file;
5262     join "", @m, "\n";
5263 }
5264
5265 sub manpage_headline {
5266   my($self,$local_file) = @_;
5267   my(@local_file) = $local_file;
5268   $local_file =~ s/\.pm(?!\n)\Z/.pod/;
5269   push @local_file, $local_file;
5270   my(@result,$locf);
5271   for $locf (@local_file) {
5272     next unless -f $locf;
5273     my $fh = FileHandle->new($locf)
5274         or $Carp::Frontend->mydie("Couldn't open $locf: $!");
5275     my $inpod = 0;
5276     local $/ = "\n";
5277     while (<$fh>) {
5278       $inpod = m/^=(?!head1\s+NAME)/ ? 0 :
5279           m/^=head1\s+NAME/ ? 1 : $inpod;
5280       next unless $inpod;
5281       next if /^=/;
5282       next if /^\s+$/;
5283       chomp;
5284       push @result, $_;
5285     }
5286     close $fh;
5287     last if @result;
5288   }
5289   join " ", @result;
5290 }
5291
5292 #-> sub CPAN::Module::cpan_file ;
5293 # Note: also inherited by CPAN::Bundle
5294 sub cpan_file {
5295     my $self = shift;
5296     CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
5297     unless (defined $self->{RO}{CPAN_FILE}) {
5298         CPAN::Index->reload;
5299     }
5300     if (exists $self->{RO}{CPAN_FILE} && defined $self->{RO}{CPAN_FILE}){
5301         return $self->{RO}{CPAN_FILE};
5302     } else {
5303         my $userid = $self->userid;
5304         if ( $userid ) {
5305             if ($CPAN::META->exists("CPAN::Author",$userid)) {
5306                 my $author = $CPAN::META->instance("CPAN::Author",
5307                                                    $userid);
5308                 my $fullname = $author->fullname;
5309                 my $email = $author->email;
5310                 unless (defined $fullname && defined $email) {
5311                     return sprintf("Contact Author %s",
5312                                    $userid,
5313                                   );
5314                 }
5315                 return "Contact Author $fullname <$email>";
5316             } else {
5317                 return "UserID $userid";
5318             }
5319         } else {
5320             return "N/A";
5321         }
5322     }
5323 }
5324
5325 #-> sub CPAN::Module::cpan_version ;
5326 sub cpan_version {
5327     my $self = shift;
5328
5329     $self->{RO}{CPAN_VERSION} = 'undef'
5330         unless defined $self->{RO}{CPAN_VERSION};
5331     # I believe this is always a bug in the index and should be reported
5332     # as such, but usually I find out such an error and do not want to
5333     # provoke too many bugreports
5334
5335     $self->{RO}{CPAN_VERSION};
5336 }
5337
5338 #-> sub CPAN::Module::force ;
5339 sub force {
5340     my($self) = @_;
5341     $self->{'force_update'}++;
5342 }
5343
5344 #-> sub CPAN::Module::rematein ;
5345 sub rematein {
5346     my($self,$meth) = @_;
5347     $CPAN::Frontend->myprint(sprintf("Running %s for module %s\n",
5348                                      $meth,
5349                                      $self->id));
5350     my $cpan_file = $self->cpan_file;
5351     if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
5352       $CPAN::Frontend->mywarn(sprintf qq{
5353   The module %s isn\'t available on CPAN.
5354
5355   Either the module has not yet been uploaded to CPAN, or it is
5356   temporary unavailable. Please contact the author to find out
5357   more about the status. Try 'i %s'.
5358 },
5359                               $self->id,
5360                               $self->id,
5361                              );
5362       return;
5363     }
5364     my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
5365     $pack->called_for($self->id);
5366     $pack->force($meth) if exists $self->{'force_update'};
5367     $pack->$meth();
5368     $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
5369     delete $self->{'force_update'};
5370 }
5371
5372 #-> sub CPAN::Module::readme ;
5373 sub readme { shift->rematein('readme') }
5374 #-> sub CPAN::Module::look ;
5375 sub look { shift->rematein('look') }
5376 #-> sub CPAN::Module::cvs_import ;
5377 sub cvs_import { shift->rematein('cvs_import') }
5378 #-> sub CPAN::Module::get ;
5379 sub get    { shift->rematein('get',@_); }
5380 #-> sub CPAN::Module::make ;
5381 sub make   {
5382     my $self = shift;
5383     $self->rematein('make');
5384 }
5385 #-> sub CPAN::Module::test ;
5386 sub test   {
5387     my $self = shift;
5388     $self->{badtestcnt} ||= 0;
5389     $self->rematein('test',@_);
5390 }
5391 #-> sub CPAN::Module::uptodate ;
5392 sub uptodate {
5393     my($self) = @_;
5394     my($latest) = $self->cpan_version;
5395     $latest ||= 0;
5396     my($inst_file) = $self->inst_file;
5397     my($have) = 0;
5398     if (defined $inst_file) {
5399         $have = $self->inst_version;
5400     }
5401     local($^W)=0;
5402     if ($inst_file
5403         &&
5404         ! CPAN::Version->vgt($latest, $have)
5405        ) {
5406         CPAN->debug("returning uptodate. inst_file[$inst_file] ".
5407                     "latest[$latest] have[$have]") if $CPAN::DEBUG;
5408         return 1;
5409     }
5410     return;
5411 }
5412 #-> sub CPAN::Module::install ;
5413 sub install {
5414     my($self) = @_;
5415     my($doit) = 0;
5416     if ($self->uptodate
5417         &&
5418         not exists $self->{'force_update'}
5419        ) {
5420         $CPAN::Frontend->myprint( $self->id. " is up to date.\n");
5421     } else {
5422         $doit = 1;
5423     }
5424     $self->rematein('install') if $doit;
5425 }
5426 #-> sub CPAN::Module::clean ;
5427 sub clean  { shift->rematein('clean') }
5428
5429 #-> sub CPAN::Module::inst_file ;
5430 sub inst_file {
5431     my($self) = @_;
5432     my($dir,@packpath);
5433     @packpath = split /::/, $self->{ID};
5434     $packpath[-1] .= ".pm";
5435     foreach $dir (@INC) {
5436         my $pmfile = File::Spec->catfile($dir,@packpath);
5437         if (-f $pmfile){
5438             return $pmfile;
5439         }
5440     }
5441     return;
5442 }
5443
5444 #-> sub CPAN::Module::xs_file ;
5445 sub xs_file {
5446     my($self) = @_;
5447     my($dir,@packpath);
5448     @packpath = split /::/, $self->{ID};
5449     push @packpath, $packpath[-1];
5450     $packpath[-1] .= "." . $Config::Config{'dlext'};
5451     foreach $dir (@INC) {
5452         my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
5453         if (-f $xsfile){
5454             return $xsfile;
5455         }
5456     }
5457     return;
5458 }
5459
5460 #-> sub CPAN::Module::inst_version ;
5461 sub inst_version {
5462     my($self) = @_;
5463     my $parsefile = $self->inst_file or return;
5464     local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
5465     my $have;
5466
5467     # there was a bug in 5.6.0 that let lots of unini warnings out of
5468     # parse_version. Fixed shortly after 5.6.0 by PMQS. We can remove
5469     # the following workaround after 5.6.1 is out.
5470     local($SIG{__WARN__}) =  sub { my $w = shift;
5471                                    return if $w =~ /uninitialized/i;
5472                                    warn $w;
5473                                  };
5474
5475     $have = MM->parse_version($parsefile) || "undef";
5476     $have =~ s/^ //; # since the %vd hack these two lines here are needed
5477     $have =~ s/ $//; # trailing whitespace happens all the time
5478
5479     # My thoughts about why %vd processing should happen here
5480
5481     # Alt1 maintain it as string with leading v:
5482     # read index files     do nothing
5483     # compare it           use utility for compare
5484     # print it             do nothing
5485
5486     # Alt2 maintain it as what it is
5487     # read index files     convert
5488     # compare it           use utility because there's still a ">" vs "gt" issue
5489     # print it             use CPAN::Version for print
5490
5491     # Seems cleaner to hold it in memory as a string starting with a "v"
5492
5493     # If the author of this module made a mistake and wrote a quoted
5494     # "v1.13" instead of v1.13, we simply leave it at that with the
5495     # effect that *we* will treat it like a v-tring while the rest of
5496     # perl won't. Seems sensible when we consider that any action we
5497     # could take now would just add complexity.
5498
5499     $have = CPAN::Version->readable($have);
5500
5501     $have =~ s/\s*//g; # stringify to float around floating point issues
5502     $have; # no stringify needed, \s* above matches always
5503 }
5504
5505 package CPAN::Tarzip;
5506
5507 # CPAN::Tarzip::gzip
5508 sub gzip {
5509   my($class,$read,$write) = @_;
5510   if ($CPAN::META->has_inst("Compress::Zlib")) {
5511     my($buffer,$fhw);
5512     $fhw = FileHandle->new($read)
5513         or $CPAN::Frontend->mydie("Could not open $read: $!");
5514     my $gz = Compress::Zlib::gzopen($write, "wb")
5515         or $CPAN::Frontend->mydie("Cannot gzopen $write: $!\n");
5516     $gz->gzwrite($buffer)
5517         while read($fhw,$buffer,4096) > 0 ;
5518     $gz->gzclose() ;
5519     $fhw->close;
5520     return 1;
5521   } else {
5522     system("$CPAN::Config->{gzip} -c $read > $write")==0;
5523   }
5524 }
5525
5526
5527 # CPAN::Tarzip::gunzip
5528 sub gunzip {
5529   my($class,$read,$write) = @_;
5530   if ($CPAN::META->has_inst("Compress::Zlib")) {
5531     my($buffer,$fhw);
5532     $fhw = FileHandle->new(">$write")
5533         or $CPAN::Frontend->mydie("Could not open >$write: $!");
5534     my $gz = Compress::Zlib::gzopen($read, "rb")
5535         or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
5536     $fhw->print($buffer)
5537         while $gz->gzread($buffer) > 0 ;
5538     $CPAN::Frontend->mydie("Error reading from $read: $!\n")
5539         if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
5540     $gz->gzclose() ;
5541     $fhw->close;
5542     return 1;
5543   } else {
5544     system("$CPAN::Config->{gzip} -dc $read > $write")==0;
5545   }
5546 }
5547
5548
5549 # CPAN::Tarzip::gtest
5550 sub gtest {
5551   my($class,$read) = @_;
5552   # After I had reread the documentation in zlib.h, I discovered that
5553   # uncompressed files do not lead to an gzerror (anymore?).
5554   if ( $CPAN::META->has_inst("Compress::Zlib") ) {
5555     my($buffer,$len);
5556     $len = 0;
5557     my $gz = Compress::Zlib::gzopen($read, "rb")
5558         or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
5559                                           $read,
5560                                           $Compress::Zlib::gzerrno));
5561     while ($gz->gzread($buffer) > 0 ){
5562         $len += length($buffer);
5563         $buffer = "";
5564     }
5565     my $err = $gz->gzerror;
5566     my $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
5567     if ($len == -s $read){
5568         $success = 0;
5569         CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
5570     }
5571     $gz->gzclose();
5572     CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
5573     return $success;
5574   } else {
5575       return system("$CPAN::Config->{gzip} -dt $read")==0;
5576   }
5577 }
5578
5579
5580 # CPAN::Tarzip::TIEHANDLE
5581 sub TIEHANDLE {
5582   my($class,$file) = @_;
5583   my $ret;
5584   $class->debug("file[$file]");
5585   if ($CPAN::META->has_inst("Compress::Zlib")) {
5586     my $gz = Compress::Zlib::gzopen($file,"rb") or
5587         die "Could not gzopen $file";
5588     $ret = bless {GZ => $gz}, $class;
5589   } else {
5590     my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $file |";
5591     my $fh = FileHandle->new($pipe) or die "Could not pipe[$pipe]: $!";
5592     binmode $fh;
5593     $ret = bless {FH => $fh}, $class;
5594   }
5595   $ret;
5596 }
5597
5598
5599 # CPAN::Tarzip::READLINE
5600 sub READLINE {
5601   my($self) = @_;
5602   if (exists $self->{GZ}) {
5603     my $gz = $self->{GZ};
5604     my($line,$bytesread);
5605     $bytesread = $gz->gzreadline($line);
5606     return undef if $bytesread <= 0;
5607     return $line;
5608   } else {
5609     my $fh = $self->{FH};
5610     return scalar <$fh>;
5611   }
5612 }
5613
5614
5615 # CPAN::Tarzip::READ
5616 sub READ {
5617   my($self,$ref,$length,$offset) = @_;
5618   die "read with offset not implemented" if defined $offset;
5619   if (exists $self->{GZ}) {
5620     my $gz = $self->{GZ};
5621     my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
5622     return $byteread;
5623   } else {
5624     my $fh = $self->{FH};
5625     return read($fh,$$ref,$length);
5626   }
5627 }
5628
5629
5630 # CPAN::Tarzip::DESTROY
5631 sub DESTROY {
5632     my($self) = @_;
5633     if (exists $self->{GZ}) {
5634         my $gz = $self->{GZ};
5635         $gz->gzclose() if defined $gz; # hard to say if it is allowed
5636                                        # to be undef ever. AK, 2000-09
5637     } else {
5638         my $fh = $self->{FH};
5639         $fh->close if defined $fh;
5640     }
5641     undef $self;
5642 }
5643
5644
5645 # CPAN::Tarzip::untar
5646 sub untar {
5647   my($class,$file) = @_;
5648   my($prefer) = 0;
5649
5650   if (0) { # makes changing order easier
5651   } elsif ($BUGHUNTING){
5652       $prefer=2;
5653   } elsif (MM->maybe_command($CPAN::Config->{gzip})
5654            &&
5655            MM->maybe_command($CPAN::Config->{'tar'})) {
5656       # should be default until Archive::Tar is fixed
5657       $prefer = 1;
5658   } elsif (
5659            $CPAN::META->has_inst("Archive::Tar")
5660            &&
5661            $CPAN::META->has_inst("Compress::Zlib") ) {
5662       $prefer = 2;
5663   } else {
5664     $CPAN::Frontend->mydie(qq{
5665 CPAN.pm needs either both external programs tar and gzip installed or
5666 both the modules Archive::Tar and Compress::Zlib. Neither prerequisite
5667 is available. Can\'t continue.
5668 });
5669   }
5670   if ($prefer==1) { # 1 => external gzip+tar
5671     my($system);
5672     my $is_compressed = $class->gtest($file);
5673     if ($is_compressed) {
5674         $system = "$CPAN::Config->{gzip} --decompress --stdout " .
5675             "< $file | $CPAN::Config->{tar} xvf -";
5676     } else {
5677         $system = "$CPAN::Config->{tar} xvf $file";
5678     }
5679     if (system($system) != 0) {
5680         # people find the most curious tar binaries that cannot handle
5681         # pipes
5682         if ($is_compressed) {
5683             (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
5684             if (CPAN::Tarzip->gunzip($file, $ungzf)) {
5685                 $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
5686             } else {
5687                 $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
5688             }
5689             $file = $ungzf;
5690         }
5691         $system = "$CPAN::Config->{tar} xvf $file";
5692         $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
5693         if (system($system)==0) {
5694             $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
5695         } else {
5696             $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
5697         }
5698         return 1;
5699     } else {
5700         return 1;
5701     }
5702   } elsif ($prefer==2) { # 2 => modules
5703     my $tar = Archive::Tar->new($file,1);
5704     my $af; # archive file
5705     my @af;
5706     if ($BUGHUNTING) {
5707         # RCS 1.337 had this code, it turned out unacceptable slow but
5708         # it revealed a bug in Archive::Tar. Code is only here to hunt
5709         # the bug again. It should never be enabled in published code.
5710         # GDGraph3d-0.53 was an interesting case according to Larry
5711         # Virden.
5712         warn(">>>Bughunting code enabled<<< " x 20);
5713         for $af ($tar->list_files) {
5714             if ($af =~ m!^(/|\.\./)!) {
5715                 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5716                                        "illegal member [$af]");
5717             }
5718             $CPAN::Frontend->myprint("$af\n");
5719             $tar->extract($af); # slow but effective for finding the bug
5720             return if $CPAN::Signal;
5721         }
5722     } else {
5723         for $af ($tar->list_files) {
5724             if ($af =~ m!^(/|\.\./)!) {
5725                 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5726                                        "illegal member [$af]");
5727             }
5728             $CPAN::Frontend->myprint("$af\n");
5729             push @af, $af;
5730             return if $CPAN::Signal;
5731         }
5732         $tar->extract(@af);
5733     }
5734
5735     Mac::BuildTools::convert_files([$tar->list_files], 1)
5736         if ($^O eq 'MacOS');
5737
5738     return 1;
5739   }
5740 }
5741
5742 sub unzip {
5743     my($class,$file) = @_;
5744     if ($CPAN::META->has_inst("Archive::Zip")) {
5745         # blueprint of the code from Archive::Zip::Tree::extractTree();
5746         my $zip = Archive::Zip->new();
5747         my $status;
5748         $status = $zip->read($file);
5749         die "Read of file[$file] failed\n" if $status != Archive::Zip::AZ_OK();
5750         $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
5751         my @members = $zip->members();
5752         for my $member ( @members ) {
5753             my $af = $member->fileName();
5754             if ($af =~ m!^(/|\.\./)!) {
5755                 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5756                                        "illegal member [$af]");
5757             }
5758             my $status = $member->extractToFileNamed( $af );
5759             $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
5760             die "Extracting of file[$af] from zipfile[$file] failed\n" if
5761                 $status != Archive::Zip::AZ_OK();
5762             return if $CPAN::Signal;
5763         }
5764         return 1;
5765     } else {
5766         my $unzip = $CPAN::Config->{unzip} or
5767             $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
5768         my @system = ($unzip, $file);
5769         return system(@system) == 0;
5770     }
5771 }
5772
5773
5774 package CPAN::Version;
5775 # CPAN::Version::vcmp courtesy Jost Krieger
5776 sub vcmp {
5777   my($self,$l,$r) = @_;
5778   local($^W) = 0;
5779   CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
5780
5781   return 0 if $l eq $r; # short circuit for quicker success
5782
5783   if ($l=~/^v/ <=> $r=~/^v/) {
5784       for ($l,$r) {
5785           next if /^v/;
5786           $_ = $self->float2vv($_);
5787       }
5788   }
5789
5790   return
5791       ($l ne "undef") <=> ($r ne "undef") ||
5792           ($] >= 5.006 &&
5793            $l =~ /^v/ &&
5794            $r =~ /^v/ &&
5795            $self->vstring($l) cmp $self->vstring($r)) ||
5796                $l <=> $r ||
5797                    $l cmp $r;
5798 }
5799
5800 sub vgt {
5801   my($self,$l,$r) = @_;
5802   $self->vcmp($l,$r) > 0;
5803 }
5804
5805 sub vstring {
5806   my($self,$n) = @_;
5807   $n =~ s/^v// or die "CPAN::Version::vstring() called with invalid arg [$n]";
5808   pack "U*", split /\./, $n;
5809 }
5810
5811 # vv => visible vstring
5812 sub float2vv {
5813     my($self,$n) = @_;
5814     my($rev) = int($n);
5815     $rev ||= 0;
5816     my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit
5817                                           # architecture influence
5818     $mantissa ||= 0;
5819     $mantissa .= "0" while length($mantissa)%3;
5820     my $ret = "v" . $rev;
5821     while ($mantissa) {
5822         $mantissa =~ s/(\d{1,3})// or
5823             die "Panic: length>0 but not a digit? mantissa[$mantissa]";
5824         $ret .= ".".int($1);
5825     }
5826     # warn "n[$n]ret[$ret]";
5827     $ret;
5828 }
5829
5830 sub readable {
5831   my($self,$n) = @_;
5832   $n =~ /^([\w\-\+\.]+)/;
5833
5834   return $1 if defined $1 && length($1)>0;
5835   # if the first user reaches version v43, he will be treated as "+".
5836   # We'll have to decide about a new rule here then, depending on what
5837   # will be the prevailing versioning behavior then.
5838
5839   if ($] < 5.006) { # or whenever v-strings were introduced
5840     # we get them wrong anyway, whatever we do, because 5.005 will
5841     # have already interpreted 0.2.4 to be "0.24". So even if he
5842     # indexer sends us something like "v0.2.4" we compare wrongly.
5843
5844     # And if they say v1.2, then the old perl takes it as "v12"
5845
5846     $CPAN::Frontend->mywarn("Suspicious version string seen [$n]");
5847     return $n;
5848   }
5849   my $better = sprintf "v%vd", $n;
5850   CPAN->debug("n[$n] better[$better]") if $CPAN::DEBUG;
5851   return $better;
5852 }
5853
5854 package CPAN;
5855
5856 1;
5857
5858 __END__
5859
5860 =head1 NAME
5861
5862 CPAN - query, download and build perl modules from CPAN sites
5863
5864 =head1 SYNOPSIS
5865
5866 Interactive mode:
5867
5868   perl -MCPAN -e shell;
5869
5870 Batch mode:
5871
5872   use CPAN;
5873
5874   autobundle, clean, install, make, recompile, test
5875
5876 =head1 DESCRIPTION
5877
5878 The CPAN module is designed to automate the make and install of perl
5879 modules and extensions. It includes some searching capabilities and
5880 knows how to use Net::FTP or LWP (or lynx or an external ftp client)
5881 to fetch the raw data from the net.
5882
5883 Modules are fetched from one or more of the mirrored CPAN
5884 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
5885 directory.
5886
5887 The CPAN module also supports the concept of named and versioned
5888 I<bundles> of modules. Bundles simplify the handling of sets of
5889 related modules. See Bundles below.
5890
5891 The package contains a session manager and a cache manager. There is
5892 no status retained between sessions. The session manager keeps track
5893 of what has been fetched, built and installed in the current
5894 session. The cache manager keeps track of the disk space occupied by
5895 the make processes and deletes excess space according to a simple FIFO
5896 mechanism.
5897
5898 For extended searching capabilities there's a plugin for CPAN available,
5899 L<C<CPAN::WAIT>|CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine
5900 that indexes all documents available in CPAN authors directories. If
5901 C<CPAN::WAIT> is installed on your system, the interactive shell of
5902 CPAN.pm will enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands
5903 which send queries to the WAIT server that has been configured for your
5904 installation.
5905
5906 All other methods provided are accessible in a programmer style and in an
5907 interactive shell style.
5908
5909 =head2 Interactive Mode
5910
5911 The interactive mode is entered by running
5912
5913     perl -MCPAN -e shell
5914
5915 which puts you into a readline interface. You will have the most fun if
5916 you install Term::ReadKey and Term::ReadLine to enjoy both history and
5917 command completion.
5918
5919 Once you are on the command line, type 'h' and the rest should be
5920 self-explanatory.
5921
5922 The function call C<shell> takes two optional arguments, one is the
5923 prompt, the second is the default initial command line (the latter
5924 only works if a real ReadLine interface module is installed).
5925
5926 The most common uses of the interactive modes are
5927
5928 =over 2
5929
5930 =item Searching for authors, bundles, distribution files and modules
5931
5932 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
5933 for each of the four categories and another, C<i> for any of the
5934 mentioned four. Each of the four entities is implemented as a class
5935 with slightly differing methods for displaying an object.
5936
5937 Arguments you pass to these commands are either strings exactly matching
5938 the identification string of an object or regular expressions that are
5939 then matched case-insensitively against various attributes of the
5940 objects. The parser recognizes a regular expression only if you
5941 enclose it between two slashes.
5942
5943 The principle is that the number of found objects influences how an
5944 item is displayed. If the search finds one item, the result is
5945 displayed with the rather verbose method C<as_string>, but if we find
5946 more than one, we display each object with the terse method
5947 <as_glimpse>.
5948
5949 =item make, test, install, clean  modules or distributions
5950
5951 These commands take any number of arguments and investigate what is
5952 necessary to perform the action. If the argument is a distribution
5953 file name (recognized by embedded slashes), it is processed. If it is
5954 a module, CPAN determines the distribution file in which this module
5955 is included and processes that, following any dependencies named in
5956 the module's Makefile.PL (this behavior is controlled by
5957 I<prerequisites_policy>.)
5958
5959 Any C<make> or C<test> are run unconditionally. An
5960
5961   install <distribution_file>
5962
5963 also is run unconditionally. But for
5964
5965   install <module>
5966
5967 CPAN checks if an install is actually needed for it and prints
5968 I<module up to date> in the case that the distribution file containing
5969 the module doesn't need to be updated.
5970
5971 CPAN also keeps track of what it has done within the current session
5972 and doesn't try to build a package a second time regardless if it
5973 succeeded or not. The C<force> command takes as a first argument the
5974 method to invoke (currently: C<make>, C<test>, or C<install>) and executes the
5975 command from scratch.
5976
5977 Example:
5978
5979     cpan> install OpenGL
5980     OpenGL is up to date.
5981     cpan> force install OpenGL
5982     Running make
5983     OpenGL-0.4/
5984     OpenGL-0.4/COPYRIGHT
5985     [...]
5986
5987 A C<clean> command results in a
5988
5989   make clean
5990
5991 being executed within the distribution file's working directory.
5992
5993 =item get, readme, look module or distribution
5994
5995 C<get> downloads a distribution file without further action. C<readme>
5996 displays the README file of the associated distribution. C<Look> gets
5997 and untars (if not yet done) the distribution file, changes to the
5998 appropriate directory and opens a subshell process in that directory.
5999
6000 =item ls author
6001
6002 C<ls> lists all distribution files in and below an author's CPAN
6003 directory. Only those files that contain modules are listed and if
6004 there is more than one for any given module, only the most recent one
6005 is listed.
6006
6007 =item Signals
6008
6009 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
6010 in the cpan-shell it is intended that you can press C<^C> anytime and
6011 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
6012 to clean up and leave the shell loop. You can emulate the effect of a
6013 SIGTERM by sending two consecutive SIGINTs, which usually means by
6014 pressing C<^C> twice.
6015
6016 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
6017 SIGALRM is used during the run of the C<perl Makefile.PL> subprocess.
6018
6019 =back
6020
6021 =head2 CPAN::Shell
6022
6023 The commands that are available in the shell interface are methods in
6024 the package CPAN::Shell. If you enter the shell command, all your
6025 input is split by the Text::ParseWords::shellwords() routine which
6026 acts like most shells do. The first word is being interpreted as the
6027 method to be called and the rest of the words are treated as arguments
6028 to this method. Continuation lines are supported if a line ends with a
6029 literal backslash.
6030
6031 =head2 autobundle
6032
6033 C<autobundle> writes a bundle file into the
6034 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
6035 a list of all modules that are both available from CPAN and currently
6036 installed within @INC. The name of the bundle file is based on the
6037 current date and a counter.
6038
6039 =head2 recompile
6040
6041 recompile() is a very special command in that it takes no argument and
6042 runs the make/test/install cycle with brute force over all installed
6043 dynamically loadable extensions (aka XS modules) with 'force' in
6044 effect. The primary purpose of this command is to finish a network
6045 installation. Imagine, you have a common source tree for two different
6046 architectures. You decide to do a completely independent fresh
6047 installation. You start on one architecture with the help of a Bundle
6048 file produced earlier. CPAN installs the whole Bundle for you, but
6049 when you try to repeat the job on the second architecture, CPAN
6050 responds with a C<"Foo up to date"> message for all modules. So you
6051 invoke CPAN's recompile on the second architecture and you're done.
6052
6053 Another popular use for C<recompile> is to act as a rescue in case your
6054 perl breaks binary compatibility. If one of the modules that CPAN uses
6055 is in turn depending on binary compatibility (so you cannot run CPAN
6056 commands), then you should try the CPAN::Nox module for recovery.
6057
6058 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
6059
6060 Although it may be considered internal, the class hierarchy does matter
6061 for both users and programmer. CPAN.pm deals with above mentioned four
6062 classes, and all those classes share a set of methods. A classical
6063 single polymorphism is in effect. A metaclass object registers all
6064 objects of all kinds and indexes them with a string. The strings
6065 referencing objects have a separated namespace (well, not completely
6066 separated):
6067
6068          Namespace                         Class
6069
6070    words containing a "/" (slash)      Distribution
6071     words starting with Bundle::          Bundle
6072           everything else            Module or Author
6073
6074 Modules know their associated Distribution objects. They always refer
6075 to the most recent official release. Developers may mark their releases
6076 as unstable development versions (by inserting an underbar into the
6077 module version number which will also be reflected in the distribution
6078 name when you run 'make dist'), so the really hottest and newest
6079 distribution is not always the default.  If a module Foo circulates
6080 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
6081 way to install version 1.23 by saying
6082
6083     install Foo
6084
6085 This would install the complete distribution file (say
6086 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
6087 like to install version 1.23_90, you need to know where the
6088 distribution file resides on CPAN relative to the authors/id/
6089 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
6090 so you would have to say
6091
6092     install BAR/Foo-1.23_90.tar.gz
6093
6094 The first example will be driven by an object of the class
6095 CPAN::Module, the second by an object of class CPAN::Distribution.
6096
6097 =head2 Programmer's interface
6098
6099 If you do not enter the shell, the available shell commands are both
6100 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
6101 functions in the calling package (C<install(...)>).
6102
6103 There's currently only one class that has a stable interface -
6104 CPAN::Shell. All commands that are available in the CPAN shell are
6105 methods of the class CPAN::Shell. Each of the commands that produce
6106 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
6107 the IDs of all modules within the list.
6108
6109 =over 2
6110
6111 =item expand($type,@things)
6112
6113 The IDs of all objects available within a program are strings that can
6114 be expanded to the corresponding real objects with the
6115 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
6116 list of CPAN::Module objects according to the C<@things> arguments
6117 given. In scalar context it only returns the first element of the
6118 list.
6119
6120 =item expandany(@things)
6121
6122 Like expand, but returns objects of the appropriate type, i.e.
6123 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
6124 CPAN::Distribution objects fro distributions.
6125
6126 =item Programming Examples
6127
6128 This enables the programmer to do operations that combine
6129 functionalities that are available in the shell.
6130
6131     # install everything that is outdated on my disk:
6132     perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
6133
6134     # install my favorite programs if necessary:
6135     for $mod (qw(Net::FTP Digest::MD5 Data::Dumper)){
6136         my $obj = CPAN::Shell->expand('Module',$mod);
6137         $obj->install;
6138     }
6139
6140     # list all modules on my disk that have no VERSION number
6141     for $mod (CPAN::Shell->expand("Module","/./")){
6142         next unless $mod->inst_file;
6143         # MakeMaker convention for undefined $VERSION:
6144         next unless $mod->inst_version eq "undef";
6145         print "No VERSION in ", $mod->id, "\n";
6146     }
6147
6148     # find out which distribution on CPAN contains a module:
6149     print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
6150
6151 Or if you want to write a cronjob to watch The CPAN, you could list
6152 all modules that need updating. First a quick and dirty way:
6153
6154     perl -e 'use CPAN; CPAN::Shell->r;'
6155
6156 If you don't want to get any output in the case that all modules are
6157 up to date, you can parse the output of above command for the regular
6158 expression //modules are up to date// and decide to mail the output
6159 only if it doesn't match. Ick?
6160
6161 If you prefer to do it more in a programmer style in one single
6162 process, maybe something like this suits you better:
6163
6164   # list all modules on my disk that have newer versions on CPAN
6165   for $mod (CPAN::Shell->expand("Module","/./")){
6166     next unless $mod->inst_file;
6167     next if $mod->uptodate;
6168     printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
6169         $mod->id, $mod->inst_version, $mod->cpan_version;
6170   }
6171
6172 If that gives you too much output every day, you maybe only want to
6173 watch for three modules. You can write
6174
6175   for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
6176
6177 as the first line instead. Or you can combine some of the above
6178 tricks:
6179
6180   # watch only for a new mod_perl module
6181   $mod = CPAN::Shell->expand("Module","mod_perl");
6182   exit if $mod->uptodate;
6183   # new mod_perl arrived, let me know all update recommendations
6184   CPAN::Shell->r;
6185
6186 =back
6187
6188 =head2 Methods in the other Classes
6189
6190 The programming interface for the classes CPAN::Module,
6191 CPAN::Distribution, CPAN::Bundle, and CPAN::Author is still considered
6192 beta and partially even alpha. In the following paragraphs only those
6193 methods are documented that have proven useful over a longer time and
6194 thus are unlikely to change.
6195
6196 =over 4
6197
6198 =item CPAN::Author::as_glimpse()
6199
6200 Returns a one-line description of the author
6201
6202 =item CPAN::Author::as_string()
6203
6204 Returns a multi-line description of the author
6205
6206 =item CPAN::Author::email()
6207
6208 Returns the author's email address
6209
6210 =item CPAN::Author::fullname()
6211
6212 Returns the author's name
6213
6214 =item CPAN::Author::name()
6215
6216 An alias for fullname
6217
6218 =item CPAN::Bundle::as_glimpse()
6219
6220 Returns a one-line description of the bundle
6221
6222 =item CPAN::Bundle::as_string()
6223
6224 Returns a multi-line description of the bundle
6225
6226 =item CPAN::Bundle::clean()
6227
6228 Recursively runs the C<clean> method on all items contained in the bundle.
6229
6230 =item CPAN::Bundle::contains()
6231
6232 Returns a list of objects' IDs contained in a bundle. The associated
6233 objects may be bundles, modules or distributions.
6234
6235 =item CPAN::Bundle::force($method,@args)
6236
6237 Forces CPAN to perform a task that normally would have failed. Force
6238 takes as arguments a method name to be called and any number of
6239 additional arguments that should be passed to the called method. The
6240 internals of the object get the needed changes so that CPAN.pm does
6241 not refuse to take the action. The C<force> is passed recursively to
6242 all contained objects.
6243
6244 =item CPAN::Bundle::get()
6245
6246 Recursively runs the C<get> method on all items contained in the bundle
6247
6248 =item CPAN::Bundle::inst_file()
6249
6250 Returns the highest installed version of the bundle in either @INC or
6251 C<$CPAN::Config->{cpan_home}>. Note that this is different from
6252 CPAN::Module::inst_file.
6253
6254 =item CPAN::Bundle::inst_version()
6255
6256 Like CPAN::Bundle::inst_file, but returns the $VERSION
6257
6258 =item CPAN::Bundle::uptodate()
6259
6260 Returns 1 if the bundle itself and all its members are uptodate.
6261
6262 =item CPAN::Bundle::install()
6263
6264 Recursively runs the C<install> method on all items contained in the bundle
6265
6266 =item CPAN::Bundle::make()
6267
6268 Recursively runs the C<make> method on all items contained in the bundle
6269
6270 =item CPAN::Bundle::readme()
6271
6272 Recursively runs the C<readme> method on all items contained in the bundle
6273
6274 =item CPAN::Bundle::test()
6275
6276 Recursively runs the C<test> method on all items contained in the bundle
6277
6278 =item CPAN::Distribution::as_glimpse()
6279
6280 Returns a one-line description of the distribution
6281
6282 =item CPAN::Distribution::as_string()
6283
6284 Returns a multi-line description of the distribution
6285
6286 =item CPAN::Distribution::clean()
6287
6288 Changes to the directory where the distribution has been unpacked and
6289 runs C<make clean> there.
6290
6291 =item CPAN::Distribution::containsmods()
6292
6293 Returns a list of IDs of modules contained in a distribution file.
6294 Only works for distributions listed in the 02packages.details.txt.gz
6295 file. This typically means that only the most recent version of a
6296 distribution is covered.
6297
6298 =item CPAN::Distribution::cvs_import()
6299
6300 Changes to the directory where the distribution has been unpacked and
6301 runs something like
6302
6303     cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
6304
6305 there.
6306
6307 =item CPAN::Distribution::dir()
6308
6309 Returns the directory into which this distribution has been unpacked.
6310
6311 =item CPAN::Distribution::force($method,@args)
6312
6313 Forces CPAN to perform a task that normally would have failed. Force
6314 takes as arguments a method name to be called and any number of
6315 additional arguments that should be passed to the called method. The
6316 internals of the object get the needed changes so that CPAN.pm does
6317 not refuse to take the action.
6318
6319 =item CPAN::Distribution::get()
6320
6321 Downloads the distribution from CPAN and unpacks it. Does nothing if
6322 the distribution has already been downloaded and unpacked within the
6323 current session.
6324
6325 =item CPAN::Distribution::install()
6326
6327 Changes to the directory where the distribution has been unpacked and
6328 runs the external command C<make install> there. If C<make> has not
6329 yet been run, it will be run first. A C<make test> will be issued in
6330 any case and if this fails, the install will be canceled. The
6331 cancellation can be avoided by letting C<force> run the C<install> for
6332 you.
6333
6334 =item CPAN::Distribution::isa_perl()
6335
6336 Returns 1 if this distribution file seems to be a perl distribution.
6337 Normally this is derived from the file name only, but the index from
6338 CPAN can contain a hint to achieve a return value of true for other
6339 filenames too.
6340
6341 =item CPAN::Distribution::look()
6342
6343 Changes to the directory where the distribution has been unpacked and
6344 opens a subshell there. Exiting the subshell returns.
6345
6346 =item CPAN::Distribution::make()
6347
6348 First runs the C<get> method to make sure the distribution is
6349 downloaded and unpacked. Changes to the directory where the
6350 distribution has been unpacked and runs the external commands C<perl
6351 Makefile.PL> and C<make> there.
6352
6353 =item CPAN::Distribution::prereq_pm()
6354
6355 Returns the hash reference that has been announced by a distribution
6356 as the PREREQ_PM hash in the Makefile.PL. Note: works only after an
6357 attempt has been made to C<make> the distribution. Returns undef
6358 otherwise.
6359
6360 =item CPAN::Distribution::readme()
6361
6362 Downloads the README file associated with a distribution and runs it
6363 through the pager specified in C<$CPAN::Config->{pager}>.
6364
6365 =item CPAN::Distribution::test()
6366
6367 Changes to the directory where the distribution has been unpacked and
6368 runs C<make test> there.
6369
6370 =item CPAN::Distribution::uptodate()
6371
6372 Returns 1 if all the modules contained in the distribution are
6373 uptodate. Relies on containsmods.
6374
6375 =item CPAN::Index::force_reload()
6376
6377 Forces a reload of all indices.
6378
6379 =item CPAN::Index::reload()
6380
6381 Reloads all indices if they have been read more than
6382 C<$CPAN::Config->{index_expire}> days.
6383
6384 =item CPAN::InfoObj::dump()
6385
6386 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
6387 inherit this method. It prints the data structure associated with an
6388 object. Useful for debugging. Note: the data structure is considered
6389 internal and thus subject to change without notice.
6390
6391 =item CPAN::Module::as_glimpse()
6392
6393 Returns a one-line description of the module
6394
6395 =item CPAN::Module::as_string()
6396
6397 Returns a multi-line description of the module
6398
6399 =item CPAN::Module::clean()
6400
6401 Runs a clean on the distribution associated with this module.
6402
6403 =item CPAN::Module::cpan_file()
6404
6405 Returns the filename on CPAN that is associated with the module.
6406
6407 =item CPAN::Module::cpan_version()
6408
6409 Returns the latest version of this module available on CPAN.
6410
6411 =item CPAN::Module::cvs_import()
6412
6413 Runs a cvs_import on the distribution associated with this module.
6414
6415 =item CPAN::Module::description()
6416
6417 Returns a 44 character description of this module. Only available for
6418 modules listed in The Module List (CPAN/modules/00modlist.long.html
6419 or 00modlist.long.txt.gz)
6420
6421 =item CPAN::Module::force($method,@args)
6422
6423 Forces CPAN to perform a task that normally would have failed. Force
6424 takes as arguments a method name to be called and any number of
6425 additional arguments that should be passed to the called method. The
6426 internals of the object get the needed changes so that CPAN.pm does
6427 not refuse to take the action.
6428
6429 =item CPAN::Module::get()
6430
6431 Runs a get on the distribution associated with this module.
6432
6433 =item CPAN::Module::inst_file()
6434
6435 Returns the filename of the module found in @INC. The first file found
6436 is reported just like perl itself stops searching @INC when it finds a
6437 module.
6438
6439 =item CPAN::Module::inst_version()
6440
6441 Returns the version number of the module in readable format.
6442
6443 =item CPAN::Module::install()
6444
6445 Runs an C<install> on the distribution associated with this module.
6446
6447 =item CPAN::Module::look()
6448
6449 Changes to the directory where the distribution associated with this
6450 module has been unpacked and opens a subshell there. Exiting the
6451 subshell returns.
6452
6453 =item CPAN::Module::make()
6454
6455 Runs a C<make> on the distribution associated with this module.
6456
6457 =item CPAN::Module::manpage_headline()
6458
6459 If module is installed, peeks into the module's manpage, reads the
6460 headline and returns it. Moreover, if the module has been downloaded
6461 within this session, does the equivalent on the downloaded module even
6462 if it is not installed.
6463
6464 =item CPAN::Module::readme()
6465
6466 Runs a C<readme> on the distribution associated with this module.
6467
6468 =item CPAN::Module::test()
6469
6470 Runs a C<test> on the distribution associated with this module.
6471
6472 =item CPAN::Module::uptodate()
6473
6474 Returns 1 if the module is installed and up-to-date.
6475
6476 =item CPAN::Module::userid()
6477
6478 Returns the author's ID of the module.
6479
6480 =back
6481
6482 =head2 Cache Manager
6483
6484 Currently the cache manager only keeps track of the build directory
6485 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
6486 deletes complete directories below C<build_dir> as soon as the size of
6487 all directories there gets bigger than $CPAN::Config->{build_cache}
6488 (in MB). The contents of this cache may be used for later
6489 re-installations that you intend to do manually, but will never be
6490 trusted by CPAN itself. This is due to the fact that the user might
6491 use these directories for building modules on different architectures.
6492
6493 There is another directory ($CPAN::Config->{keep_source_where}) where
6494 the original distribution files are kept. This directory is not
6495 covered by the cache manager and must be controlled by the user. If
6496 you choose to have the same directory as build_dir and as
6497 keep_source_where directory, then your sources will be deleted with
6498 the same fifo mechanism.
6499
6500 =head2 Bundles
6501
6502 A bundle is just a perl module in the namespace Bundle:: that does not
6503 define any functions or methods. It usually only contains documentation.
6504
6505 It starts like a perl module with a package declaration and a $VERSION
6506 variable. After that the pod section looks like any other pod with the
6507 only difference being that I<one special pod section> exists starting with
6508 (verbatim):
6509
6510         =head1 CONTENTS
6511
6512 In this pod section each line obeys the format
6513
6514         Module_Name [Version_String] [- optional text]
6515
6516 The only required part is the first field, the name of a module
6517 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
6518 of the line is optional. The comment part is delimited by a dash just
6519 as in the man page header.
6520
6521 The distribution of a bundle should follow the same convention as
6522 other distributions.
6523
6524 Bundles are treated specially in the CPAN package. If you say 'install
6525 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
6526 the modules in the CONTENTS section of the pod. You can install your
6527 own Bundles locally by placing a conformant Bundle file somewhere into
6528 your @INC path. The autobundle() command which is available in the
6529 shell interface does that for you by including all currently installed
6530 modules in a snapshot bundle file.
6531
6532 =head2 Prerequisites
6533
6534 If you have a local mirror of CPAN and can access all files with
6535 "file:" URLs, then you only need a perl better than perl5.003 to run
6536 this module. Otherwise Net::FTP is strongly recommended. LWP may be
6537 required for non-UNIX systems or if your nearest CPAN site is
6538 associated with a URL that is not C<ftp:>.
6539
6540 If you have neither Net::FTP nor LWP, there is a fallback mechanism
6541 implemented for an external ftp command or for an external lynx
6542 command.
6543
6544 =head2 Finding packages and VERSION
6545
6546 This module presumes that all packages on CPAN
6547
6548 =over 2
6549
6550 =item *
6551
6552 declare their $VERSION variable in an easy to parse manner. This
6553 prerequisite can hardly be relaxed because it consumes far too much
6554 memory to load all packages into the running program just to determine
6555 the $VERSION variable. Currently all programs that are dealing with
6556 version use something like this
6557
6558     perl -MExtUtils::MakeMaker -le \
6559         'print MM->parse_version(shift)' filename
6560
6561 If you are author of a package and wonder if your $VERSION can be
6562 parsed, please try the above method.
6563
6564 =item *
6565
6566 come as compressed or gzipped tarfiles or as zip files and contain a
6567 Makefile.PL (well, we try to handle a bit more, but without much
6568 enthusiasm).
6569
6570 =back
6571
6572 =head2 Debugging
6573
6574 The debugging of this module is a bit complex, because we have
6575 interferences of the software producing the indices on CPAN, of the
6576 mirroring process on CPAN, of packaging, of configuration, of
6577 synchronicity, and of bugs within CPAN.pm.
6578
6579 For code debugging in interactive mode you can try "o debug" which
6580 will list options for debugging the various parts of the code. You
6581 should know that "o debug" has built-in completion support.
6582
6583 For data debugging there is the C<dump> command which takes the same
6584 arguments as make/test/install and outputs the object's Data::Dumper
6585 dump.
6586
6587 =head2 Floppy, Zip, Offline Mode
6588
6589 CPAN.pm works nicely without network too. If you maintain machines
6590 that are not networked at all, you should consider working with file:
6591 URLs. Of course, you have to collect your modules somewhere first. So
6592 you might use CPAN.pm to put together all you need on a networked
6593 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
6594 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
6595 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
6596 with this floppy. See also below the paragraph about CD-ROM support.
6597
6598 =head1 CONFIGURATION
6599
6600 When the CPAN module is installed, a site wide configuration file is
6601 created as CPAN/Config.pm. The default values defined there can be
6602 overridden in another configuration file: CPAN/MyConfig.pm. You can
6603 store this file in $HOME/.cpan/CPAN/MyConfig.pm if you want, because
6604 $HOME/.cpan is added to the search path of the CPAN module before the
6605 use() or require() statements.
6606
6607 Currently the following keys in the hash reference $CPAN::Config are
6608 defined:
6609
6610   build_cache        size of cache for directories to build modules
6611   build_dir          locally accessible directory to build modules
6612   index_expire       after this many days refetch index files
6613   cache_metadata     use serializer to cache metadata
6614   cpan_home          local directory reserved for this package
6615   dontload_hash      anonymous hash: modules in the keys will not be
6616                      loaded by the CPAN::has_inst() routine
6617   gzip               location of external program gzip
6618   inactivity_timeout breaks interactive Makefile.PLs after this
6619                      many seconds inactivity. Set to 0 to never break.
6620   inhibit_startup_message
6621                      if true, does not print the startup message
6622   keep_source_where  directory in which to keep the source (if we do)
6623   make               location of external make program
6624   make_arg           arguments that should always be passed to 'make'
6625   make_install_arg   same as make_arg for 'make install'
6626   makepl_arg         arguments passed to 'perl Makefile.PL'
6627   pager              location of external program more (or any pager)
6628   prerequisites_policy
6629                      what to do if you are missing module prerequisites
6630                      ('follow' automatically, 'ask' me, or 'ignore')
6631   proxy_user         username for accessing an authenticating proxy
6632   proxy_pass         password for accessing an authenticating proxy
6633   scan_cache         controls scanning of cache ('atstart' or 'never')
6634   tar                location of external program tar
6635   term_is_latin      if true internal UTF-8 is translated to ISO-8859-1
6636                      (and nonsense for characters outside latin range)
6637   unzip              location of external program unzip
6638   urllist            arrayref to nearby CPAN sites (or equivalent locations)
6639   wait_list          arrayref to a wait server to try (See CPAN::WAIT)
6640   ftp_proxy,      }  the three usual variables for configuring
6641     http_proxy,   }  proxy requests. Both as CPAN::Config variables
6642     no_proxy      }  and as environment variables configurable.
6643
6644 You can set and query each of these options interactively in the cpan
6645 shell with the command set defined within the C<o conf> command:
6646
6647 =over 2
6648
6649 =item C<o conf E<lt>scalar optionE<gt>>
6650
6651 prints the current value of the I<scalar option>
6652
6653 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
6654
6655 Sets the value of the I<scalar option> to I<value>
6656
6657 =item C<o conf E<lt>list optionE<gt>>
6658
6659 prints the current value of the I<list option> in MakeMaker's
6660 neatvalue format.
6661
6662 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
6663
6664 shifts or pops the array in the I<list option> variable
6665
6666 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
6667
6668 works like the corresponding perl commands.
6669
6670 =back
6671
6672 =head2 Note on urllist parameter's format
6673
6674 urllist parameters are URLs according to RFC 1738. We do a little
6675 guessing if your URL is not compliant, but if you have problems with
6676 file URLs, please try the correct format. Either:
6677
6678     file://localhost/whatever/ftp/pub/CPAN/
6679
6680 or
6681
6682     file:///home/ftp/pub/CPAN/
6683
6684 =head2 urllist parameter has CD-ROM support
6685
6686 The C<urllist> parameter of the configuration table contains a list of
6687 URLs that are to be used for downloading. If the list contains any
6688 C<file> URLs, CPAN always tries to get files from there first. This
6689 feature is disabled for index files. So the recommendation for the
6690 owner of a CD-ROM with CPAN contents is: include your local, possibly
6691 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
6692
6693   o conf urllist push file://localhost/CDROM/CPAN
6694
6695 CPAN.pm will then fetch the index files from one of the CPAN sites
6696 that come at the beginning of urllist. It will later check for each
6697 module if there is a local copy of the most recent version.
6698
6699 Another peculiarity of urllist is that the site that we could
6700 successfully fetch the last file from automatically gets a preference
6701 token and is tried as the first site for the next request. So if you
6702 add a new site at runtime it may happen that the previously preferred
6703 site will be tried another time. This means that if you want to disallow
6704 a site for the next transfer, it must be explicitly removed from
6705 urllist.
6706
6707 =head1 SECURITY
6708
6709 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
6710 install foreign, unmasked, unsigned code on your machine. We compare
6711 to a checksum that comes from the net just as the distribution file
6712 itself. If somebody has managed to tamper with the distribution file,
6713 they may have as well tampered with the CHECKSUMS file. Future
6714 development will go towards strong authentication.
6715
6716 =head1 EXPORT
6717
6718 Most functions in package CPAN are exported per default. The reason
6719 for this is that the primary use is intended for the cpan shell or for
6720 one-liners.
6721
6722 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
6723
6724 Populating a freshly installed perl with my favorite modules is pretty
6725 easy if you maintain a private bundle definition file. To get a useful
6726 blueprint of a bundle definition file, the command autobundle can be used
6727 on the CPAN shell command line. This command writes a bundle definition
6728 file for all modules that are installed for the currently running perl
6729 interpreter. It's recommended to run this command only once and from then
6730 on maintain the file manually under a private name, say
6731 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
6732
6733     cpan> install Bundle::my_bundle
6734
6735 then answer a few questions and then go out for a coffee.
6736
6737 Maintaining a bundle definition file means keeping track of two
6738 things: dependencies and interactivity. CPAN.pm sometimes fails on
6739 calculating dependencies because not all modules define all MakeMaker
6740 attributes correctly, so a bundle definition file should specify
6741 prerequisites as early as possible. On the other hand, it's a bit
6742 annoying that many distributions need some interactive configuring. So
6743 what I try to accomplish in my private bundle file is to have the
6744 packages that need to be configured early in the file and the gentle
6745 ones later, so I can go out after a few minutes and leave CPAN.pm
6746 untended.
6747
6748 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
6749
6750 Thanks to Graham Barr for contributing the following paragraphs about
6751 the interaction between perl, and various firewall configurations. For
6752 further informations on firewalls, it is recommended to consult the
6753 documentation that comes with the ncftp program. If you are unable to
6754 go through the firewall with a simple Perl setup, it is very likely
6755 that you can configure ncftp so that it works for your firewall.
6756
6757 =head2 Three basic types of firewalls
6758
6759 Firewalls can be categorized into three basic types.
6760
6761 =over 4
6762
6763 =item http firewall
6764
6765 This is where the firewall machine runs a web server and to access the
6766 outside world you must do it via the web server. If you set environment
6767 variables like http_proxy or ftp_proxy to a values beginning with http://
6768 or in your web browser you have to set proxy information then you know
6769 you are running an http firewall.
6770
6771 To access servers outside these types of firewalls with perl (even for
6772 ftp) you will need to use LWP.
6773
6774 =item ftp firewall
6775
6776 This where the firewall machine runs an ftp server. This kind of
6777 firewall will only let you access ftp servers outside the firewall.
6778 This is usually done by connecting to the firewall with ftp, then
6779 entering a username like "user@outside.host.com"
6780
6781 To access servers outside these type of firewalls with perl you
6782 will need to use Net::FTP.
6783
6784 =item One way visibility
6785
6786 I say one way visibility as these firewalls try to make themselves look
6787 invisible to the users inside the firewall. An FTP data connection is
6788 normally created by sending the remote server your IP address and then
6789 listening for the connection. But the remote server will not be able to
6790 connect to you because of the firewall. So for these types of firewall
6791 FTP connections need to be done in a passive mode.
6792
6793 There are two that I can think off.
6794
6795 =over 4
6796
6797 =item SOCKS
6798
6799 If you are using a SOCKS firewall you will need to compile perl and link
6800 it with the SOCKS library, this is what is normally called a 'socksified'
6801 perl. With this executable you will be able to connect to servers outside
6802 the firewall as if it is not there.
6803
6804 =item IP Masquerade
6805
6806 This is the firewall implemented in the Linux kernel, it allows you to
6807 hide a complete network behind one IP address. With this firewall no
6808 special compiling is needed as you can access hosts directly.
6809
6810 =back
6811
6812 =back
6813
6814 =head2 Configuring lynx or ncftp for going through a firewall
6815
6816 If you can go through your firewall with e.g. lynx, presumably with a
6817 command such as
6818
6819     /usr/local/bin/lynx -pscott:tiger
6820
6821 then you would configure CPAN.pm with the command
6822
6823     o conf lynx "/usr/local/bin/lynx -pscott:tiger"
6824
6825 That's all. Similarly for ncftp or ftp, you would configure something
6826 like
6827
6828     o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
6829
6830 Your mileage may vary...
6831
6832 =head1 FAQ
6833
6834 =over 4
6835
6836 =item 1)
6837
6838 I installed a new version of module X but CPAN keeps saying,
6839 I have the old version installed
6840
6841 Most probably you B<do> have the old version installed. This can
6842 happen if a module installs itself into a different directory in the
6843 @INC path than it was previously installed. This is not really a
6844 CPAN.pm problem, you would have the same problem when installing the
6845 module manually. The easiest way to prevent this behaviour is to add
6846 the argument C<UNINST=1> to the C<make install> call, and that is why
6847 many people add this argument permanently by configuring
6848
6849   o conf make_install_arg UNINST=1
6850
6851 =item 2)
6852
6853 So why is UNINST=1 not the default?
6854
6855 Because there are people who have their precise expectations about who
6856 may install where in the @INC path and who uses which @INC array. In
6857 fine tuned environments C<UNINST=1> can cause damage.
6858
6859 =item 3)
6860
6861 I want to clean up my mess, and install a new perl along with
6862 all modules I have. How do I go about it?
6863
6864 Run the autobundle command for your old perl and optionally rename the
6865 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
6866 with the Configure option prefix, e.g.
6867
6868     ./Configure -Dprefix=/usr/local/perl-5.6.78.9
6869
6870 Install the bundle file you produced in the first step with something like
6871
6872     cpan> install Bundle::mybundle
6873
6874 and you're done.
6875
6876 =item 4)
6877
6878 When I install bundles or multiple modules with one command
6879 there is too much output to keep track of.
6880
6881 You may want to configure something like
6882
6883   o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
6884   o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
6885
6886 so that STDOUT is captured in a file for later inspection.
6887
6888
6889 =item 5)
6890
6891 I am not root, how can I install a module in a personal directory?
6892
6893 You will most probably like something like this:
6894
6895   o conf makepl_arg "LIB=~/myperl/lib \
6896                     INSTALLMAN1DIR=~/myperl/man/man1 \
6897                     INSTALLMAN3DIR=~/myperl/man/man3"
6898   install Sybase::Sybperl
6899
6900 You can make this setting permanent like all C<o conf> settings with
6901 C<o conf commit>.
6902
6903 You will have to add ~/myperl/man to the MANPATH environment variable
6904 and also tell your perl programs to look into ~/myperl/lib, e.g. by
6905 including
6906
6907   use lib "$ENV{HOME}/myperl/lib";
6908
6909 or setting the PERL5LIB environment variable.
6910
6911 Another thing you should bear in mind is that the UNINST parameter
6912 should never be set if you are not root.
6913
6914 =item 6)
6915
6916 How to get a package, unwrap it, and make a change before building it?
6917
6918   look Sybase::Sybperl
6919
6920 =item 7)
6921
6922 I installed a Bundle and had a couple of fails. When I
6923 retried, everything resolved nicely. Can this be fixed to work
6924 on first try?
6925
6926 The reason for this is that CPAN does not know the dependencies of all
6927 modules when it starts out. To decide about the additional items to
6928 install, it just uses data found in the generated Makefile. An
6929 undetected missing piece breaks the process. But it may well be that
6930 your Bundle installs some prerequisite later than some depending item
6931 and thus your second try is able to resolve everything. Please note,
6932 CPAN.pm does not know the dependency tree in advance and cannot sort
6933 the queue of things to install in a topologically correct order. It
6934 resolves perfectly well IFF all modules declare the prerequisites
6935 correctly with the PREREQ_PM attribute to MakeMaker. For bundles which
6936 fail and you need to install often, it is recommended sort the Bundle
6937 definition file manually. It is planned to improve the metadata
6938 situation for dependencies on CPAN in general, but this will still
6939 take some time.
6940
6941 =item 8)
6942
6943 In our intranet we have many modules for internal use. How
6944 can I integrate these modules with CPAN.pm but without uploading
6945 the modules to CPAN?
6946
6947 Have a look at the CPAN::Site module.
6948
6949 =item 9)
6950
6951 When I run CPAN's shell, I get error msg about line 1 to 4,
6952 setting meta input/output via the /etc/inputrc file.
6953
6954 Some versions of readline are picky about capitalization in the
6955 /etc/inputrc file and specifically RedHat 6.2 comes with a
6956 /etc/inputrc that contains the word C<on> in lowercase. Change the
6957 occurrences of C<on> to C<On> and the bug should disappear.
6958
6959 =item 10)
6960
6961 Some authors have strange characters in their names.
6962
6963 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
6964 expecting ISO-8859-1 charset, a converter can be activated by setting
6965 term_is_latin to a true value in your config file. One way of doing so
6966 would be
6967
6968     cpan> ! $CPAN::Config->{term_is_latin}=1
6969
6970 Extended support for converters will be made available as soon as perl
6971 becomes stable with regard to charset issues.
6972
6973 =back
6974
6975 =head1 BUGS
6976
6977 We should give coverage for B<all> of the CPAN and not just the PAUSE
6978 part, right? In this discussion CPAN and PAUSE have become equal --
6979 but they are not. PAUSE is authors/, modules/ and scripts/. CPAN is
6980 PAUSE plus the clpa/, doc/, misc/, ports/, and src/.
6981
6982 Future development should be directed towards a better integration of
6983 the other parts.
6984
6985 If a Makefile.PL requires special customization of libraries, prompts
6986 the user for special input, etc. then you may find CPAN is not able to
6987 build the distribution. In that case, you should attempt the
6988 traditional method of building a Perl module package from a shell.
6989
6990 =head1 AUTHOR
6991
6992 Andreas Koenig E<lt>andreas.koenig@anima.deE<gt>
6993
6994 =head1 TRANSLATIONS
6995
6996 Kawai,Takanori provides a Japanese translation of this manpage at
6997 http://member.nifty.ne.jp/hippo2000/perltips/CPAN.htm
6998
6999 =head1 SEE ALSO
7000
7001 perl(1), CPAN::Nox(3)
7002
7003 =cut
7004