lib/CPAN.pm

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