lib/CPAN.pm

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