lib/CPAN.pm

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