lib/CPAN.pm

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