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