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: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
3329             PATH_COMPONENT: foreach $component (MM->path(),
3330                                                 $Config::Config{'binexp'}) {
3331                   next unless defined($component) && $component;
3332                   my($abs) = MM->catfile($component,$perl_name);
3333                   if (MM->maybe_command($abs)) {
3334                       $perl = $abs;
3335                       last DIST_PERLNAME;
3336                   }
3337               }
3338           }
3339     }
3340     $perl;
3341 }
3342
3343 #-> sub CPAN::Distribution::make ;
3344 sub make {
3345     my($self) = @_;
3346     $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id);
3347     # Emergency brake if they said install Pippi and get newest perl
3348     if ($self->isa_perl) {
3349       if (
3350           $self->called_for ne $self->id && ! $self->{'force_update'}
3351          ) {
3352         $CPAN::Frontend->mydie(sprintf qq{
3353 The most recent version "%s" of the module "%s"
3354 comes with the current version of perl (%s).
3355 I\'ll build that only if you ask for something like
3356     force install %s
3357 or
3358     install %s
3359 },
3360                                $CPAN::META->instance(
3361                                                      'CPAN::Module',
3362                                                      $self->called_for
3363                                                     )->cpan_version,
3364                                $self->called_for,
3365                                $self->isa_perl,
3366                                $self->called_for,
3367                                $self->id);
3368       }
3369     }
3370     $self->get;
3371   EXCUSE: {
3372         my @e;
3373         $self->{archived} eq "NO" and push @e,
3374         "Is neither a tar nor a zip archive.";
3375
3376         $self->{unwrapped} eq "NO" and push @e,
3377         "had problems unarchiving. Please build manually";
3378
3379         exists $self->{writemakefile} &&
3380             $self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e,
3381                 $1 || "Had some problem writing Makefile";
3382
3383         defined $self->{'make'} and push @e,
3384         "Has already been processed within this session";
3385
3386         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
3387     }
3388     $CPAN::Frontend->myprint("\n  CPAN.pm: Going to build ".$self->id."\n\n");
3389     my $builddir = $self->dir;
3390     chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
3391     $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
3392
3393     if ($^O eq 'MacOS') {
3394         ExtUtils::MM_MacOS::make($self);
3395         return;
3396     }
3397
3398     my $system;
3399     if ($self->{'configure'}) {
3400       $system = $self->{'configure'};
3401     } else {
3402         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
3403         my $switch = "";
3404 # This needs a handler that can be turned on or off:
3405 #       $switch = "-MExtUtils::MakeMaker ".
3406 #           "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
3407 #           if $] > 5.00310;
3408         $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
3409     }
3410     unless (exists $self->{writemakefile}) {
3411         local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
3412         my($ret,$pid);
3413         $@ = "";
3414         if ($CPAN::Config->{inactivity_timeout}) {
3415             eval {
3416                 alarm $CPAN::Config->{inactivity_timeout};
3417                 local $SIG{CHLD}; # = sub { wait };
3418                 if (defined($pid = fork)) {
3419                     if ($pid) { #parent
3420                         # wait;
3421                         waitpid $pid, 0;
3422                     } else {    #child
3423                       # note, this exec isn't necessary if
3424                       # inactivity_timeout is 0. On the Mac I'd
3425                       # suggest, we set it always to 0.
3426                       exec $system;
3427                     }
3428                 } else {
3429                     $CPAN::Frontend->myprint("Cannot fork: $!");
3430                     return;
3431                 }
3432             };
3433             alarm 0;
3434             if ($@){
3435                 kill 9, $pid;
3436                 waitpid $pid, 0;
3437                 $CPAN::Frontend->myprint($@);
3438                 $self->{writemakefile} = "NO $@";
3439                 $@ = "";
3440                 return;
3441             }
3442         } else {
3443           $ret = system($system);
3444           if ($ret != 0) {
3445             $self->{writemakefile} = "NO Makefile.PL returned status $ret";
3446             return;
3447           }
3448         }
3449         if (-f "Makefile") {
3450           $self->{writemakefile} = "YES";
3451         } else {
3452           $self->{writemakefile} =
3453               qq{NO Makefile.PL refused to write a Makefile.};
3454           # It's probably worth to record the reason, so let's retry
3455           # local $/;
3456           # my $fh = IO::File->new("$system |"); # STDERR? STDIN?
3457           # $self->{writemakefile} .= <$fh>;
3458         }
3459     }
3460     return if $CPAN::Signal;
3461     if (my @prereq = $self->needs_prereq){
3462       my $id = $self->id;
3463       $CPAN::Frontend->myprint("---- Dependencies detected ".
3464                                "during [$id] -----\n");
3465
3466       for my $p (@prereq) {
3467         $CPAN::Frontend->myprint("    $p\n");
3468       }
3469       my $follow = 0;
3470       if ($CPAN::Config->{prerequisites_policy} eq "follow") {
3471         $follow = 1;
3472       } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
3473         require ExtUtils::MakeMaker;
3474         my $answer = ExtUtils::MakeMaker::prompt(
3475 "Shall I follow them and prepend them to the queue
3476 of modules we are processing right now?", "yes");
3477         $follow = $answer =~ /^\s*y/i;
3478       } else {
3479         local($") = ", ";
3480         $CPAN::Frontend->myprint("  Ignoring dependencies on modules @prereq\n");
3481       }
3482       if ($follow) {
3483         CPAN::Queue->jumpqueue(@prereq,$id); # requeue yourself
3484         return;
3485       }
3486     }
3487     $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
3488     if (system($system) == 0) {
3489          $CPAN::Frontend->myprint("  $system -- OK\n");
3490          $self->{'make'} = "YES";
3491     } else {
3492          $self->{writemakefile} ||= "YES";
3493          $self->{'make'} = "NO";
3494          $CPAN::Frontend->myprint("  $system -- NOT OK\n");
3495     }
3496 }
3497
3498 #-> sub CPAN::Distribution::needs_prereq ;
3499 sub needs_prereq {
3500   my($self) = @_;
3501   return unless -f "Makefile"; # we cannot say much
3502   my $fh = FileHandle->new("<Makefile") or
3503       $CPAN::Frontend->mydie("Couldn't open Makefile: $!");
3504   local($/) = "\n";
3505
3506   my(@p,@need);
3507   while (<$fh>) {
3508     last if /MakeMaker post_initialize section/;
3509     my($p) = m{^[\#]
3510                  \s+PREREQ_PM\s+=>\s+(.+)
3511                  }x;
3512     next unless $p;
3513     # warn "Found prereq expr[$p]";
3514
3515     while ( $p =~ m/(?:\s)([\w\:]+)=>q\[.*?\],?/g ){
3516       push @p, $1;
3517     }
3518     last;
3519   }
3520   for my $p (@p) {
3521     my $mo = $CPAN::META->instance("CPAN::Module",$p);
3522     next if $mo->uptodate;
3523     # it's not needed, so don't push it. We cannot omit this step, because
3524     # if 'force' is in effect, nobody else will check.
3525     if ($self->{have_sponsored}{$p}++){
3526       # We have already sponsored it and for some reason it's still
3527       # not available. So we do nothing. Or what should we do?
3528       # if we push it again, we have a potential infinite loop
3529       next;
3530     }
3531     push @need, $p;
3532   }
3533   return @need;
3534 }
3535
3536 #-> sub CPAN::Distribution::test ;
3537 sub test {
3538     my($self) = @_;
3539     $self->make;
3540     return if $CPAN::Signal;
3541     $CPAN::Frontend->myprint("Running make test\n");
3542   EXCUSE: {
3543         my @e;
3544         exists $self->{'make'} or push @e,
3545         "Make had some problems, maybe interrupted? Won't test";
3546
3547         exists $self->{'make'} and
3548             $self->{'make'} eq 'NO' and
3549                 push @e, "Oops, make had returned bad status";
3550
3551         exists $self->{'build_dir'} or push @e, "Has no own directory";
3552         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
3553     }
3554     chdir $self->{'build_dir'} or
3555         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
3556     $self->debug("Changed directory to $self->{'build_dir'}")
3557         if $CPAN::DEBUG;
3558
3559     if ($^O eq 'MacOS') {
3560         ExtUtils::MM_MacOS::make_test($self);
3561         return;
3562     }
3563
3564     my $system = join " ", $CPAN::Config->{'make'}, "test";
3565     if (system($system) == 0) {
3566          $CPAN::Frontend->myprint("  $system -- OK\n");
3567          $self->{'make_test'} = "YES";
3568     } else {
3569          $self->{'make_test'} = "NO";
3570          $CPAN::Frontend->myprint("  $system -- NOT OK\n");
3571     }
3572 }
3573
3574 #-> sub CPAN::Distribution::clean ;
3575 sub clean {
3576     my($self) = @_;
3577     $CPAN::Frontend->myprint("Running make clean\n");
3578   EXCUSE: {
3579         my @e;
3580         exists $self->{'build_dir'} or push @e, "Has no own directory";
3581         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
3582     }
3583     chdir $self->{'build_dir'} or
3584         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
3585     $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
3586
3587     if ($^O eq 'MacOS') {
3588         ExtUtils::MM_MacOS::make_clean($self);
3589         return;
3590     }
3591
3592     my $system = join " ", $CPAN::Config->{'make'}, "clean";
3593     if (system($system) == 0) {
3594         $CPAN::Frontend->myprint("  $system -- OK\n");
3595         $self->force;
3596     } else {
3597         # Hmmm, what to do if make clean failed?
3598     }
3599 }
3600
3601 #-> sub CPAN::Distribution::install ;
3602 sub install {
3603     my($self) = @_;
3604     $self->test;
3605     return if $CPAN::Signal;
3606     $CPAN::Frontend->myprint("Running make install\n");
3607   EXCUSE: {
3608         my @e;
3609         exists $self->{'build_dir'} or push @e, "Has no own directory";
3610
3611         exists $self->{'make'} or push @e,
3612         "Make had some problems, maybe interrupted? Won't install";
3613
3614         exists $self->{'make'} and
3615             $self->{'make'} eq 'NO' and
3616                 push @e, "Oops, make had returned bad status";
3617
3618         push @e, "make test had returned bad status, ".
3619             "won't install without force"
3620             if exists $self->{'make_test'} and
3621             $self->{'make_test'} eq 'NO' and
3622             ! $self->{'force_update'};
3623
3624         exists $self->{'install'} and push @e,
3625         $self->{'install'} eq "YES" ?
3626             "Already done" : "Already tried without success";
3627
3628         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
3629     }
3630     chdir $self->{'build_dir'} or
3631         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
3632     $self->debug("Changed directory to $self->{'build_dir'}")
3633         if $CPAN::DEBUG;
3634
3635     if ($^O eq 'MacOS') {
3636         ExtUtils::MM_MacOS::make_install($self);
3637         return;
3638     }
3639
3640     my $system = join(" ", $CPAN::Config->{'make'},
3641                       "install", $CPAN::Config->{make_install_arg});
3642     my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 ";
3643     my($pipe) = FileHandle->new("$system $stderr |");
3644     my($makeout) = "";
3645     while (<$pipe>){
3646         $CPAN::Frontend->myprint($_);
3647         $makeout .= $_;
3648     }
3649     $pipe->close;
3650     if ($?==0) {
3651          $CPAN::Frontend->myprint("  $system -- OK\n");
3652          return $self->{'install'} = "YES";
3653     } else {
3654          $self->{'install'} = "NO";
3655          $CPAN::Frontend->myprint("  $system -- NOT OK\n");
3656          if ($makeout =~ /permission/s && $> > 0) {
3657              $CPAN::Frontend->myprint(qq{    You may have to su }.
3658                                       qq{to root to install the package\n});
3659          }
3660     }
3661 }
3662
3663 #-> sub CPAN::Distribution::dir ;
3664 sub dir {
3665     shift->{'build_dir'};
3666 }
3667
3668 package CPAN::Bundle;
3669
3670 #-> sub CPAN::Bundle::as_string ;
3671 sub as_string {
3672     my($self) = @_;
3673     $self->contains;
3674     $self->{INST_VERSION} = $self->inst_version;
3675     return $self->SUPER::as_string;
3676 }
3677
3678 #-> sub CPAN::Bundle::contains ;
3679 sub contains {
3680   my($self) = @_;
3681   my($parsefile) = $self->inst_file;
3682   my($id) = $self->id;
3683   $self->debug("parsefile[$parsefile]id[$id]") if $CPAN::DEBUG;
3684   unless ($parsefile) {
3685     # Try to get at it in the cpan directory
3686     $self->debug("no parsefile") if $CPAN::DEBUG;
3687     Carp::confess "I don't know a $id" unless $self->{CPAN_FILE};
3688     my $dist = $CPAN::META->instance('CPAN::Distribution',
3689                                      $self->{CPAN_FILE});
3690     $dist->get;
3691     $self->debug($dist->as_string) if $CPAN::DEBUG;
3692     my($todir) = $CPAN::Config->{'cpan_home'};
3693     my(@me,$from,$to,$me);
3694     @me = split /::/, $self->id;
3695     $me[-1] .= ".pm";
3696     $me = MM->catfile(@me);
3697     $from = $self->find_bundle_file($dist->{'build_dir'},$me);
3698     $to = MM->catfile($todir,$me);
3699     File::Path::mkpath(File::Basename::dirname($to));
3700     File::Copy::copy($from, $to)
3701         or Carp::confess("Couldn't copy $from to $to: $!");
3702     $parsefile = $to;
3703   }
3704   my @result;
3705   my $fh = FileHandle->new;
3706   local $/ = "\n";
3707   open($fh,$parsefile) or die "Could not open '$parsefile': $!";
3708   my $inpod = 0;
3709   $self->debug("parsefile[$parsefile]") if $CPAN::DEBUG;
3710   while (<$fh>) {
3711     $inpod = m/^=(?!head1\s+CONTENTS)/ ? 0 :
3712         m/^=head1\s+CONTENTS/ ? 1 : $inpod;
3713     next unless $inpod;
3714     next if /^=/;
3715     next if /^\s+$/;
3716     chomp;
3717     push @result, (split " ", $_, 2)[0];
3718   }
3719   close $fh;
3720   delete $self->{STATUS};
3721   $self->{CONTAINS} = join ", ", @result;
3722   $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
3723   unless (@result) {
3724     $CPAN::Frontend->mywarn(qq{
3725 The bundle file "$parsefile" may be a broken
3726 bundlefile. It seems not to contain any bundle definition.
3727 Please check the file and if it is bogus, please delete it.
3728 Sorry for the inconvenience.
3729 });
3730   }
3731   @result;
3732 }
3733
3734 #-> sub CPAN::Bundle::find_bundle_file
3735 sub find_bundle_file {
3736     my($self,$where,$what) = @_;
3737     $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
3738 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
3739 ###    my $bu = MM->catfile($where,$what);
3740 ###    return $bu if -f $bu;
3741     my $manifest = MM->catfile($where,"MANIFEST");
3742     unless (-f $manifest) {
3743         require ExtUtils::Manifest;
3744         my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
3745         my $cwd = CPAN->$getcwd();
3746         chdir $where;
3747         ExtUtils::Manifest::mkmanifest();
3748         chdir $cwd;
3749     }
3750     my $fh = FileHandle->new($manifest)
3751         or Carp::croak("Couldn't open $manifest: $!");
3752     local($/) = "\n";
3753     my $what2 = $what;
3754     if ($^O eq 'MacOS') {
3755       $what =~ s/^://;
3756       $what2 =~ tr|:|/|;
3757       $what2 =~ s/:Bundle://;
3758       $what2 =~ tr|:|/|;
3759     } else {
3760         $what2 =~ s|Bundle/||;
3761     }
3762     my $bu;
3763     while (<$fh>) {
3764         next if /^\s*\#/;
3765         my($file) = /(\S+)/;
3766         if ($file =~ m|\Q$what\E$|) {
3767             $bu = $file;
3768             # return MM->catfile($where,$bu); # bad
3769             last;
3770         }
3771         # retry if she managed to
3772         # have no Bundle directory
3773         $bu = $file if $file =~ m|\Q$what2\E$|;
3774     }
3775     $bu =~ tr|/|:| if $^O eq 'MacOS';
3776     return MM->catfile($where, $bu) if $bu;
3777     Carp::croak("Couldn't find a Bundle file in $where");
3778 }
3779
3780 #-> sub CPAN::Bundle::inst_file ;
3781 sub inst_file {
3782     my($self) = @_;
3783     my($me,$inst_file);
3784     ($me = $self->id) =~ s/.*://;
3785 ##    my(@me,$inst_file);
3786 ##    @me = split /::/, $self->id;
3787 ##    $me[-1] .= ".pm";
3788     $inst_file = MM->catfile($CPAN::Config->{'cpan_home'},
3789                                       "Bundle", "$me.pm");
3790 ##                                    "Bundle", @me);
3791     return $self->{'INST_FILE'} = $inst_file if -f $inst_file;
3792 #    $inst_file =
3793     $self->SUPER::inst_file;
3794 #    return $self->{'INST_FILE'} = $inst_file if -f $inst_file;
3795 #    return $self->{'INST_FILE'}; # even if undefined?
3796 }
3797
3798 #-> sub CPAN::Bundle::rematein ;
3799 sub rematein {
3800     my($self,$meth) = @_;
3801     $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
3802     my($id) = $self->id;
3803     Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
3804         unless $self->inst_file || $self->{CPAN_FILE};
3805     my($s,%fail);
3806     for $s ($self->contains) {
3807         my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
3808             $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
3809         if ($type eq 'CPAN::Distribution') {
3810             $CPAN::Frontend->mywarn(qq{
3811 The Bundle }.$self->id.qq{ contains
3812 explicitly a file $s.
3813 });
3814             sleep 3;
3815         }
3816         # possibly noisy action:
3817         my $obj = $CPAN::META->instance($type,$s);
3818         $obj->$meth();
3819         my $success = $obj->can("uptodate") ? $obj->uptodate : 0;
3820         $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
3821         $fail{$s} = 1 unless $success;
3822     }
3823     # recap with less noise
3824     if ( $meth eq "install") {
3825         if (%fail) {
3826             $CPAN::Frontend->myprint(qq{\nBundle summary: }.
3827                                      qq{The following items seem to }.
3828                                      qq{have had installation problems:\n});
3829             for $s ($self->contains) {
3830                 $CPAN::Frontend->myprint( "$s " ) if $fail{$s};
3831             }
3832             $CPAN::Frontend->myprint(qq{\n});
3833         } else {
3834             $self->{'install'} = 'YES';
3835         }
3836     }
3837 }
3838
3839 #sub CPAN::Bundle::xs_file
3840 sub xs_file {
3841     # If a bundle contains another that contains an xs_file we have
3842     # here, we just don't bother I suppose
3843     return 0;
3844 }
3845
3846 #-> sub CPAN::Bundle::force ;
3847 sub force   { shift->rematein('force',@_); }
3848 #-> sub CPAN::Bundle::get ;
3849 sub get     { shift->rematein('get',@_); }
3850 #-> sub CPAN::Bundle::make ;
3851 sub make    { shift->rematein('make',@_); }
3852 #-> sub CPAN::Bundle::test ;
3853 sub test    { shift->rematein('test',@_); }
3854 #-> sub CPAN::Bundle::install ;
3855 sub install {
3856   my $self = shift;
3857   $self->rematein('install',@_);
3858 }
3859 #-> sub CPAN::Bundle::clean ;
3860 sub clean   { shift->rematein('clean',@_); }
3861
3862 #-> sub CPAN::Bundle::readme ;
3863 sub readme  {
3864     my($self) = @_;
3865     my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
3866 No File found for bundle } . $self->id . qq{\n}), return;
3867     $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
3868     $CPAN::META->instance('CPAN::Distribution',$file)->readme;
3869 }
3870
3871 package CPAN::Module;
3872
3873 #-> sub CPAN::Module::as_glimpse ;
3874 sub as_glimpse {
3875     my($self) = @_;
3876     my(@m);
3877     my $class = ref($self);
3878     $class =~ s/^CPAN:://;
3879     push @m, sprintf("%-15s %-15s (%s)\n", $class, $self->{ID},
3880                      $self->cpan_file);
3881     join "", @m;
3882 }
3883
3884 #-> sub CPAN::Module::as_string ;
3885 sub as_string {
3886     my($self) = @_;
3887     my(@m);
3888     CPAN->debug($self) if $CPAN::DEBUG;
3889     my $class = ref($self);
3890     $class =~ s/^CPAN:://;
3891     local($^W) = 0;
3892     push @m, $class, " id = $self->{ID}\n";
3893     my $sprintf = "    %-12s %s\n";
3894     push @m, sprintf($sprintf, 'DESCRIPTION', $self->{description})
3895         if $self->{description};
3896     my $sprintf2 = "    %-12s %s (%s)\n";
3897     my($userid);
3898     if ($userid = $self->{'CPAN_USERID'} || $self->{'userid'}){
3899         my $author;
3900         if ($author = CPAN::Shell->expand('Author',$userid)) {
3901           my $email = "";
3902           my $m; # old perls
3903           if ($m = $author->email) {
3904             $email = " <$m>";
3905           }
3906           push @m, sprintf(
3907                            $sprintf2,
3908                            'CPAN_USERID',
3909                            $userid,
3910                            $author->fullname . $email
3911                           );
3912         }
3913     }
3914     push @m, sprintf($sprintf, 'CPAN_VERSION', $self->{CPAN_VERSION})
3915         if $self->{CPAN_VERSION};
3916     push @m, sprintf($sprintf, 'CPAN_FILE', $self->{CPAN_FILE})
3917         if $self->{CPAN_FILE};
3918     my $sprintf3 = "    %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
3919     my(%statd,%stats,%statl,%stati);
3920     @statd{qw,? i c a b R M S,} = qw,unknown idea
3921         pre-alpha alpha beta released mature standard,;
3922     @stats{qw,? m d u n,}       = qw,unknown mailing-list
3923         developer comp.lang.perl.* none,;
3924     @statl{qw,? p c + o h,}       = qw,unknown perl C C++ other hybrid,;
3925     @stati{qw,? f r O h,}         = qw,unknown functions
3926         references+ties object-oriented hybrid,;
3927     $statd{' '} = 'unknown';
3928     $stats{' '} = 'unknown';
3929     $statl{' '} = 'unknown';
3930     $stati{' '} = 'unknown';
3931     push @m, sprintf(
3932                      $sprintf3,
3933                      'DSLI_STATUS',
3934                      $self->{statd},
3935                      $self->{stats},
3936                      $self->{statl},
3937                      $self->{stati},
3938                      $statd{$self->{statd}},
3939                      $stats{$self->{stats}},
3940                      $statl{$self->{statl}},
3941                      $stati{$self->{stati}}
3942                     ) if $self->{statd};
3943     my $local_file = $self->inst_file;
3944     if ($local_file) {
3945       $self->{MANPAGE} ||= $self->manpage_headline($local_file);
3946     }
3947     my($item);
3948     for $item (qw/MANPAGE CONTAINS/) {
3949         push @m, sprintf($sprintf, $item, $self->{$item})
3950             if exists $self->{$item};
3951     }
3952     push @m, sprintf($sprintf, 'INST_FILE',
3953                      $local_file || "(not installed)");
3954     push @m, sprintf($sprintf, 'INST_VERSION',
3955                      $self->inst_version) if $local_file;
3956     join "", @m, "\n";
3957 }
3958
3959 sub manpage_headline {
3960   my($self,$local_file) = @_;
3961   my(@local_file) = $local_file;
3962   $local_file =~ s/\.pm$/.pod/;
3963   push @local_file, $local_file;
3964   my(@result,$locf);
3965   for $locf (@local_file) {
3966     next unless -f $locf;
3967     my $fh = FileHandle->new($locf)
3968         or $Carp::Frontend->mydie("Couldn't open $locf: $!");
3969     my $inpod = 0;
3970     local $/ = "\n";
3971     while (<$fh>) {
3972       $inpod = m/^=(?!head1\s+NAME)/ ? 0 :
3973           m/^=head1\s+NAME/ ? 1 : $inpod;
3974       next unless $inpod;
3975       next if /^=/;
3976       next if /^\s+$/;
3977       chomp;
3978       push @result, $_;
3979     }
3980     close $fh;
3981     last if @result;
3982   }
3983   join " ", @result;
3984 }
3985
3986 #-> sub CPAN::Module::cpan_file ;
3987 sub cpan_file    {
3988     my $self = shift;
3989     CPAN->debug($self->id) if $CPAN::DEBUG;
3990     unless (defined $self->{'CPAN_FILE'}) {
3991         CPAN::Index->reload;
3992     }
3993     if (exists $self->{'CPAN_FILE'} && defined $self->{'CPAN_FILE'}){
3994         return $self->{'CPAN_FILE'};
3995     } elsif (exists $self->{'userid'} && defined $self->{'userid'}) {
3996         my $fullname = $CPAN::META->instance(CPAN::Author,
3997                                       $self->{'userid'})->fullname;
3998         my $email = $CPAN::META->instance(CPAN::Author,
3999                                       $self->{'userid'})->email;
4000         unless (defined $fullname && defined $email) {
4001             return "Contact Author $self->{userid} (Try ``a $self->{userid}'')";
4002         }
4003         return "Contact Author $fullname <$email>";
4004     } else {
4005         return "N/A";
4006     }
4007 }
4008
4009 *name = \&cpan_file;
4010
4011 #-> sub CPAN::Module::cpan_version ;
4012 sub cpan_version {
4013     my $self = shift;
4014     $self->{'CPAN_VERSION'} = 'undef'
4015         unless defined $self->{'CPAN_VERSION'}; # I believe this is
4016                                                 # always a bug in the
4017                                                 # index and should be
4018                                                 # reported as such,
4019                                                 # but usually I find
4020                                                 # out such an error
4021                                                 # and do not want to
4022                                                 # provoke too many
4023                                                 # bugreports
4024     $self->{'CPAN_VERSION'};
4025 }
4026
4027 #-> sub CPAN::Module::force ;
4028 sub force {
4029     my($self) = @_;
4030     $self->{'force_update'}++;
4031 }
4032
4033 #-> sub CPAN::Module::rematein ;
4034 sub rematein {
4035     my($self,$meth) = @_;
4036     $self->debug($self->id) if $CPAN::DEBUG;
4037     my $cpan_file = $self->cpan_file;
4038     if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
4039       $CPAN::Frontend->mywarn(sprintf qq{
4040   The module %s isn\'t available on CPAN.
4041
4042   Either the module has not yet been uploaded to CPAN, or it is
4043   temporary unavailable. Please contact the author to find out
4044   more about the status. Try ``i %s''.
4045 },
4046                               $self->id,
4047                               $self->id,
4048                              );
4049       return;
4050     }
4051     my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
4052     $pack->called_for($self->id);
4053     $pack->force if exists $self->{'force_update'};
4054     $pack->$meth();
4055     delete $self->{'force_update'};
4056 }
4057
4058 #-> sub CPAN::Module::readme ;
4059 sub readme { shift->rematein('readme') }
4060 #-> sub CPAN::Module::look ;
4061 sub look { shift->rematein('look') }
4062 #-> sub CPAN::Module::get ;
4063 sub get    { shift->rematein('get',@_); }
4064 #-> sub CPAN::Module::make ;
4065 sub make   { shift->rematein('make') }
4066 #-> sub CPAN::Module::test ;
4067 sub test   { shift->rematein('test') }
4068 #-> sub CPAN::Module::uptodate ;
4069 sub uptodate {
4070     my($self) = @_;
4071     my($latest) = $self->cpan_version;
4072     $latest ||= 0;
4073     my($inst_file) = $self->inst_file;
4074     my($have) = 0;
4075     if (defined $inst_file) {
4076         $have = $self->inst_version;
4077     }
4078     local($^W)=0;
4079     if ($inst_file
4080         &&
4081         $have >= $latest
4082        ) {
4083       return 1;
4084     }
4085     return;
4086 }
4087 #-> sub CPAN::Module::install ;
4088 sub install {
4089     my($self) = @_;
4090     my($doit) = 0;
4091     if ($self->uptodate
4092         &&
4093         not exists $self->{'force_update'}
4094        ) {
4095         $CPAN::Frontend->myprint( $self->id. " is up to date.\n");
4096     } else {
4097         $doit = 1;
4098     }
4099     $self->rematein('install') if $doit;
4100 }
4101 #-> sub CPAN::Module::clean ;
4102 sub clean  { shift->rematein('clean') }
4103
4104 #-> sub CPAN::Module::inst_file ;
4105 sub inst_file {
4106     my($self) = @_;
4107     my($dir,@packpath);
4108     @packpath = split /::/, $self->{ID};
4109     $packpath[-1] .= ".pm";
4110     foreach $dir (@INC) {
4111         my $pmfile = MM->catfile($dir,@packpath);
4112         if (-f $pmfile){
4113             return $pmfile;
4114         }
4115     }
4116     return;
4117 }
4118
4119 #-> sub CPAN::Module::xs_file ;
4120 sub xs_file {
4121     my($self) = @_;
4122     my($dir,@packpath);
4123     @packpath = split /::/, $self->{ID};
4124     push @packpath, $packpath[-1];
4125     $packpath[-1] .= "." . $Config::Config{'dlext'};
4126     foreach $dir (@INC) {
4127         my $xsfile = MM->catfile($dir,'auto',@packpath);
4128         if (-f $xsfile){
4129             return $xsfile;
4130         }
4131     }
4132     return;
4133 }
4134
4135 #-> sub CPAN::Module::inst_version ;
4136 sub inst_version {
4137     my($self) = @_;
4138     my $parsefile = $self->inst_file or return;
4139     local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
4140     # warn "HERE";
4141     my $have = MM->parse_version($parsefile) || "undef";
4142     $have =~ s/\s+//g;
4143     $have;
4144 }
4145
4146 package CPAN::Tarzip;
4147
4148 sub gzip {
4149   my($class,$read,$write) = @_;
4150   if ($CPAN::META->has_inst("Compress::Zlib")) {
4151     my($buffer,$fhw);
4152     $fhw = FileHandle->new($read)
4153         or $CPAN::Frontend->mydie("Could not open $read: $!");
4154     my $gz = Compress::Zlib::gzopen($write, "wb")
4155         or $CPAN::Frontend->mydie("Cannot gzopen $write: $!\n");
4156     $gz->gzwrite($buffer)
4157         while read($fhw,$buffer,4096) > 0 ;
4158     $gz->gzclose() ;
4159     $fhw->close;
4160     return 1;
4161   } else {
4162     system("$CPAN::Config->{'gzip'} -c $read > $write")==0;
4163   }
4164 }
4165
4166 sub gunzip {
4167   my($class,$read,$write) = @_;
4168   if ($CPAN::META->has_inst("Compress::Zlib")) {
4169     my($buffer,$fhw);
4170     $fhw = FileHandle->new(">$write")
4171         or $CPAN::Frontend->mydie("Could not open >$write: $!");
4172     my $gz = Compress::Zlib::gzopen($read, "rb")
4173         or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
4174     $fhw->print($buffer)
4175         while $gz->gzread($buffer) > 0 ;
4176     $CPAN::Frontend->mydie("Error reading from $read: $!\n")
4177         if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
4178     $gz->gzclose() ;
4179     $fhw->close;
4180     return 1;
4181   } else {
4182     system("$CPAN::Config->{'gzip'} -dc $read > $write")==0;
4183   }
4184 }
4185
4186 sub gtest {
4187   my($class,$read) = @_;
4188   if ($CPAN::META->has_inst("Compress::Zlib")) {
4189     my($buffer);
4190     my $gz = Compress::Zlib::gzopen($read, "rb")
4191         or $CPAN::Frontend->mydie("Cannot open $read: $!\n");
4192     1 while $gz->gzread($buffer) > 0 ;
4193     $CPAN::Frontend->mydie("Error reading from $read: $!\n")
4194         if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
4195     $gz->gzclose() ;
4196     return 1;
4197   } else {
4198     return system("$CPAN::Config->{'gzip'} -dt $read")==0;
4199   }
4200 }
4201
4202 sub TIEHANDLE {
4203   my($class,$file) = @_;
4204   my $ret;
4205   $class->debug("file[$file]");
4206   if ($CPAN::META->has_inst("Compress::Zlib")) {
4207     my $gz = Compress::Zlib::gzopen($file,"rb") or
4208         die "Could not gzopen $file";
4209     $ret = bless {GZ => $gz}, $class;
4210   } else {
4211     my $pipe = "$CPAN::Config->{'gzip'} --decompress --stdout $file |";
4212     my $fh = FileHandle->new($pipe) or die "Could pipe[$pipe]: $!";
4213     binmode $fh;
4214     $ret = bless {FH => $fh}, $class;
4215   }
4216   $ret;
4217 }
4218
4219 sub READLINE {
4220   my($self) = @_;
4221   if (exists $self->{GZ}) {
4222     my $gz = $self->{GZ};
4223     my($line,$bytesread);
4224     $bytesread = $gz->gzreadline($line);
4225     return undef if $bytesread <= 0;
4226     return $line;
4227   } else {
4228     my $fh = $self->{FH};
4229     return scalar <$fh>;
4230   }
4231 }
4232
4233 sub READ {
4234   my($self,$ref,$length,$offset) = @_;
4235   die "read with offset not implemented" if defined $offset;
4236   if (exists $self->{GZ}) {
4237     my $gz = $self->{GZ};
4238     my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
4239     return $byteread;
4240   } else {
4241     my $fh = $self->{FH};
4242     return read($fh,$$ref,$length);
4243   }
4244 }
4245
4246 sub DESTROY {
4247   my($self) = @_;
4248   if (exists $self->{GZ}) {
4249     my $gz = $self->{GZ};
4250     $gz->gzclose();
4251   } else {
4252     my $fh = $self->{FH};
4253     $fh->close;
4254   }
4255   undef $self;
4256 }
4257
4258 sub untar {
4259   my($class,$file) = @_;
4260   # had to disable, because version 0.07 seems to be buggy
4261   if (MM->maybe_command($CPAN::Config->{'gzip'})
4262       &&
4263       MM->maybe_command($CPAN::Config->{'tar'})) {
4264     if ($^O =~ /win/i) { # irgggh
4265         # people find the most curious tar binaries that cannot handle
4266         # pipes
4267         my $system = "$CPAN::Config->{'gzip'} --decompress $file";
4268         if (system($system)==0) {
4269             $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
4270         } else {
4271             $CPAN::Frontend->mydie(
4272                                    qq{Couldn\'t uncompress $file\n}
4273                                   );
4274         }
4275         $file =~ s/\.gz$//;
4276         $system = "$CPAN::Config->{tar} xvf $file";
4277         if (system($system)==0) {
4278             $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
4279         } else {
4280             $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
4281         }
4282         return 1;
4283     } else {
4284         my $system = "$CPAN::Config->{'gzip'} --decompress --stdout " .
4285             "< $file | $CPAN::Config->{tar} xvf -";
4286         return system($system) == 0;
4287     }
4288   } elsif ($CPAN::META->has_inst("Archive::Tar")
4289       &&
4290       $CPAN::META->has_inst("Compress::Zlib") ) {
4291     my $tar = Archive::Tar->new($file,1);
4292     $tar->extract($tar->list_files); # I'm pretty sure we have nothing
4293                                      # that isn't compressed
4294
4295     ExtUtils::MM_MacOS::convert_files([$tar->list_files], 1)
4296         if ($^O eq 'MacOS');
4297
4298     return 1;
4299   } else {
4300     $CPAN::Frontend->mydie(qq{
4301 CPAN.pm needs either both external programs tar and gzip installed or
4302 both the modules Archive::Tar and Compress::Zlib. Neither prerequisite
4303 is available. Can\'t continue.
4304 });
4305   }
4306 }
4307
4308 package CPAN;
4309
4310 1;
4311
4312 __END__
4313
4314 =head1 NAME
4315
4316 CPAN - query, download and build perl modules from CPAN sites
4317
4318 =head1 SYNOPSIS
4319
4320 Interactive mode:
4321
4322   perl -MCPAN -e shell;
4323
4324 Batch mode:
4325
4326   use CPAN;
4327
4328   autobundle, clean, install, make, recompile, test
4329
4330 =head1 DESCRIPTION
4331
4332 The CPAN module is designed to automate the make and install of perl
4333 modules and extensions. It includes some searching capabilities and
4334 knows how to use Net::FTP or LWP (or lynx or an external ftp client)
4335 to fetch the raw data from the net.
4336
4337 Modules are fetched from one or more of the mirrored CPAN
4338 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
4339 directory.
4340
4341 The CPAN module also supports the concept of named and versioned
4342 'bundles' of modules. Bundles simplify the handling of sets of
4343 related modules. See BUNDLES below.
4344
4345 The package contains a session manager and a cache manager. There is
4346 no status retained between sessions. The session manager keeps track
4347 of what has been fetched, built and installed in the current
4348 session. The cache manager keeps track of the disk space occupied by
4349 the make processes and deletes excess space according to a simple FIFO
4350 mechanism.
4351
4352 For extended searching capabilities there's a plugin for CPAN available,
4353 L<CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine that indexes
4354 all documents available in CPAN authors directories. If C<CPAN::WAIT>
4355 is installed on your system, the interactive shell of <CPAN.pm> will
4356 enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands which send
4357 queries to the WAIT server that has been configured for your
4358 installation.
4359
4360 All other methods provided are accessible in a programmer style and in an
4361 interactive shell style.
4362
4363 =head2 Interactive Mode
4364
4365 The interactive mode is entered by running
4366
4367     perl -MCPAN -e shell
4368
4369 which puts you into a readline interface. You will have the most fun if
4370 you install Term::ReadKey and Term::ReadLine to enjoy both history and
4371 command completion.
4372
4373 Once you are on the command line, type 'h' and the rest should be
4374 self-explanatory.
4375
4376 The most common uses of the interactive modes are
4377
4378 =over 2
4379
4380 =item Searching for authors, bundles, distribution files and modules
4381
4382 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
4383 for each of the four categories and another, C<i> for any of the
4384 mentioned four. Each of the four entities is implemented as a class
4385 with slightly differing methods for displaying an object.
4386
4387 Arguments you pass to these commands are either strings exactly matching
4388 the identification string of an object or regular expressions that are
4389 then matched case-insensitively against various attributes of the
4390 objects. The parser recognizes a regular expression only if you
4391 enclose it between two slashes.
4392
4393 The principle is that the number of found objects influences how an
4394 item is displayed. If the search finds one item, the result is displayed
4395 as object-E<gt>as_string, but if we find more than one, we display
4396 each as object-E<gt>as_glimpse. E.g.
4397
4398     cpan> a ANDK
4399     Author id = ANDK
4400         EMAIL        a.koenig@franz.ww.TU-Berlin.DE
4401         FULLNAME     Andreas König
4402
4403
4404     cpan> a /andk/
4405     Author id = ANDK
4406         EMAIL        a.koenig@franz.ww.TU-Berlin.DE
4407         FULLNAME     Andreas König
4408
4409
4410     cpan> a /and.*rt/
4411     Author          ANDYD (Andy Dougherty)
4412     Author          MERLYN (Randal L. Schwartz)
4413
4414 =item make, test, install, clean  modules or distributions
4415
4416 These commands take any number of arguments and investigates what is
4417 necessary to perform the action. If the argument is a distribution
4418 file name (recognized by embedded slashes), it is processed. If it is
4419 a module, CPAN determines the distribution file in which this module
4420 is included and processes that, following any dependencies named in
4421 the module's Makefile.PL (this behavior is controlled by
4422 I<prerequisites_policy>.)
4423
4424 Any C<make> or C<test> are run unconditionally. An
4425
4426   install <distribution_file>
4427
4428 also is run unconditionally. But for
4429
4430   install <module>
4431
4432 CPAN checks if an install is actually needed for it and prints
4433 I<module up to date> in the case that the distribution file containing
4434 the module doesnE<39>t need to be updated.
4435
4436 CPAN also keeps track of what it has done within the current session
4437 and doesnE<39>t try to build a package a second time regardless if it
4438 succeeded or not. The C<force> command takes as a first argument the
4439 method to invoke (currently: C<make>, C<test>, or C<install>) and executes the
4440 command from scratch.
4441
4442 Example:
4443
4444     cpan> install OpenGL
4445     OpenGL is up to date.
4446     cpan> force install OpenGL
4447     Running make
4448     OpenGL-0.4/
4449     OpenGL-0.4/COPYRIGHT
4450     [...]
4451
4452 A C<clean> command results in a
4453
4454   make clean
4455
4456 being executed within the distribution file's working directory.
4457
4458 =item readme, look module or distribution
4459
4460 These two commands take only one argument, be it a module or a
4461 distribution file. C<readme> unconditionally runs, displaying the
4462 README of the associated distribution file. C<Look> gets and
4463 untars (if not yet done) the distribution file, changes to the
4464 appropriate directory and opens a subshell process in that directory.
4465
4466 =item Signals
4467
4468 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
4469 in the cpan-shell it is intended that you can press C<^C> anytime and
4470 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
4471 to clean up and leave the shell loop. You can emulate the effect of a
4472 SIGTERM by sending two consecutive SIGINTs, which usually means by
4473 pressing C<^C> twice.
4474
4475 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
4476 SIGALRM is used during the run of the C<perl Makefile.PL> subprocess.
4477
4478 =back
4479
4480 =head2 CPAN::Shell
4481
4482 The commands that are available in the shell interface are methods in
4483 the package CPAN::Shell. If you enter the shell command, all your
4484 input is split by the Text::ParseWords::shellwords() routine which
4485 acts like most shells do. The first word is being interpreted as the
4486 method to be called and the rest of the words are treated as arguments
4487 to this method. Continuation lines are supported if a line ends with a
4488 literal backslash.
4489
4490 =head2 autobundle
4491
4492 C<autobundle> writes a bundle file into the
4493 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
4494 a list of all modules that are both available from CPAN and currently
4495 installed within @INC. The name of the bundle file is based on the
4496 current date and a counter.
4497
4498 =head2 recompile
4499
4500 recompile() is a very special command in that it takes no argument and
4501 runs the make/test/install cycle with brute force over all installed
4502 dynamically loadable extensions (aka XS modules) with 'force' in
4503 effect. The primary purpose of this command is to finish a network
4504 installation. Imagine, you have a common source tree for two different
4505 architectures. You decide to do a completely independent fresh
4506 installation. You start on one architecture with the help of a Bundle
4507 file produced earlier. CPAN installs the whole Bundle for you, but
4508 when you try to repeat the job on the second architecture, CPAN
4509 responds with a C<"Foo up to date"> message for all modules. So you
4510 invoke CPAN's recompile on the second architecture and youE<39>re done.
4511
4512 Another popular use for C<recompile> is to act as a rescue in case your
4513 perl breaks binary compatibility. If one of the modules that CPAN uses
4514 is in turn depending on binary compatibility (so you cannot run CPAN
4515 commands), then you should try the CPAN::Nox module for recovery.
4516
4517 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
4518
4519 Although it may be considered internal, the class hierarchy does matter
4520 for both users and programmer. CPAN.pm deals with above mentioned four
4521 classes, and all those classes share a set of methods. A classical
4522 single polymorphism is in effect. A metaclass object registers all
4523 objects of all kinds and indexes them with a string. The strings
4524 referencing objects have a separated namespace (well, not completely
4525 separated):
4526
4527          Namespace                         Class
4528
4529    words containing a "/" (slash)      Distribution
4530     words starting with Bundle::          Bundle
4531           everything else            Module or Author
4532
4533 Modules know their associated Distribution objects. They always refer
4534 to the most recent official release. Developers may mark their releases
4535 as unstable development versions (by inserting an underbar into the
4536 visible version number), so the really hottest and newest distribution
4537 file is not always the default.  If a module Foo circulates on CPAN in
4538 both version 1.23 and 1.23_90, CPAN.pm offers a convenient way to
4539 install version 1.23 by saying
4540
4541     install Foo
4542
4543 This would install the complete distribution file (say
4544 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
4545 like to install version 1.23_90, you need to know where the
4546 distribution file resides on CPAN relative to the authors/id/
4547 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
4548 so you would have to say
4549
4550     install BAR/Foo-1.23_90.tar.gz
4551
4552 The first example will be driven by an object of the class
4553 CPAN::Module, the second by an object of class CPAN::Distribution.
4554
4555 =head2 ProgrammerE<39>s interface
4556
4557 If you do not enter the shell, the available shell commands are both
4558 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
4559 functions in the calling package (C<install(...)>).
4560
4561 There's currently only one class that has a stable interface -
4562 CPAN::Shell. All commands that are available in the CPAN shell are
4563 methods of the class CPAN::Shell. Each of the commands that produce
4564 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
4565 the IDs of all modules within the list.
4566
4567 =over 2
4568
4569 =item expand($type,@things)
4570
4571 The IDs of all objects available within a program are strings that can
4572 be expanded to the corresponding real objects with the
4573 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
4574 list of CPAN::Module objects according to the C<@things> arguments
4575 given. In scalar context it only returns the first element of the
4576 list.
4577
4578 =item Programming Examples
4579
4580 This enables the programmer to do operations that combine
4581 functionalities that are available in the shell.
4582
4583     # install everything that is outdated on my disk:
4584     perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
4585
4586     # install my favorite programs if necessary:
4587     for $mod (qw(Net::FTP MD5 Data::Dumper)){
4588         my $obj = CPAN::Shell->expand('Module',$mod);
4589         $obj->install;
4590     }
4591
4592     # list all modules on my disk that have no VERSION number
4593     for $mod (CPAN::Shell->expand("Module","/./")){
4594         next unless $mod->inst_file;
4595         # MakeMaker convention for undefined $VERSION:
4596         next unless $mod->inst_version eq "undef";
4597         print "No VERSION in ", $mod->id, "\n";
4598     }
4599
4600 Or if you want to write a cronjob to watch The CPAN, you could list
4601 all modules that need updating:
4602
4603     perl -e 'use CPAN; CPAN::Shell->r;'
4604
4605 If you don't want to get any output if all modules are up to date, you
4606 can parse the output of above command for the regular expression
4607 //modules are up to date// and decide to mail the output only if it
4608 doesn't match. Ick?
4609
4610 If you prefer to do it more in a programmer style in one single
4611 process, maybe something like this suites you better:
4612
4613   # list all modules on my disk that have newer versions on CPAN
4614   for $mod (CPAN::Shell->expand("Module","/./")){
4615     next unless $mod->inst_file;
4616     next if $mod->uptodate;
4617     printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
4618         $mod->id, $mod->inst_version, $mod->cpan_version;
4619   }
4620
4621 If that gives you too much output every day, you maybe only want to
4622 watch for three modules. You can write
4623
4624   for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
4625
4626 as the first line instead. Or you can combine some of the above
4627 tricks:
4628
4629   # watch only for a new mod_perl module
4630   $mod = CPAN::Shell->expand("Module","mod_perl");
4631   exit if $mod->uptodate;
4632   # new mod_perl arrived, let me know all update recommendations
4633   CPAN::Shell->r;
4634
4635 =back
4636
4637 =head2 Methods in the four Classes
4638
4639 =head2 Cache Manager
4640
4641 Currently the cache manager only keeps track of the build directory
4642 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
4643 deletes complete directories below C<build_dir> as soon as the size of
4644 all directories there gets bigger than $CPAN::Config->{build_cache}
4645 (in MB). The contents of this cache may be used for later
4646 re-installations that you intend to do manually, but will never be
4647 trusted by CPAN itself. This is due to the fact that the user might
4648 use these directories for building modules on different architectures.
4649
4650 There is another directory ($CPAN::Config->{keep_source_where}) where
4651 the original distribution files are kept. This directory is not
4652 covered by the cache manager and must be controlled by the user. If
4653 you choose to have the same directory as build_dir and as
4654 keep_source_where directory, then your sources will be deleted with
4655 the same fifo mechanism.
4656
4657 =head2 Bundles
4658
4659 A bundle is just a perl module in the namespace Bundle:: that does not
4660 define any functions or methods. It usually only contains documentation.
4661
4662 It starts like a perl module with a package declaration and a $VERSION
4663 variable. After that the pod section looks like any other pod with the
4664 only difference being that I<one special pod section> exists starting with
4665 (verbatim):
4666
4667         =head1 CONTENTS
4668
4669 In this pod section each line obeys the format
4670
4671         Module_Name [Version_String] [- optional text]
4672
4673 The only required part is the first field, the name of a module
4674 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
4675 of the line is optional. The comment part is delimited by a dash just
4676 as in the man page header.
4677
4678 The distribution of a bundle should follow the same convention as
4679 other distributions.
4680
4681 Bundles are treated specially in the CPAN package. If you say 'install
4682 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
4683 the modules in the CONTENTS section of the pod. You can install your
4684 own Bundles locally by placing a conformant Bundle file somewhere into
4685 your @INC path. The autobundle() command which is available in the
4686 shell interface does that for you by including all currently installed
4687 modules in a snapshot bundle file.
4688
4689 =head2 Prerequisites
4690
4691 If you have a local mirror of CPAN and can access all files with
4692 "file:" URLs, then you only need a perl better than perl5.003 to run
4693 this module. Otherwise Net::FTP is strongly recommended. LWP may be
4694 required for non-UNIX systems or if your nearest CPAN site is
4695 associated with an URL that is not C<ftp:>.
4696
4697 If you have neither Net::FTP nor LWP, there is a fallback mechanism
4698 implemented for an external ftp command or for an external lynx
4699 command.
4700
4701 =head2 Finding packages and VERSION
4702
4703 This module presumes that all packages on CPAN
4704
4705 =over 2
4706
4707 =item *
4708
4709 declare their $VERSION variable in an easy to parse manner. This
4710 prerequisite can hardly be relaxed because it consumes far too much
4711 memory to load all packages into the running program just to determine
4712 the $VERSION variable. Currently all programs that are dealing with
4713 version use something like this
4714
4715     perl -MExtUtils::MakeMaker -le \
4716         'print MM->parse_version(shift)' filename
4717
4718 If you are author of a package and wonder if your $VERSION can be
4719 parsed, please try the above method.
4720
4721 =item *
4722
4723 come as compressed or gzipped tarfiles or as zip files and contain a
4724 Makefile.PL (well, we try to handle a bit more, but without much
4725 enthusiasm).
4726
4727 =back
4728
4729 =head2 Debugging
4730
4731 The debugging of this module is pretty difficult, because we have
4732 interferences of the software producing the indices on CPAN, of the
4733 mirroring process on CPAN, of packaging, of configuration, of
4734 synchronicity, and of bugs within CPAN.pm.
4735
4736 In interactive mode you can try "o debug" which will list options for
4737 debugging the various parts of the package. The output may not be very
4738 useful for you as it's just a by-product of my own testing, but if you
4739 have an idea which part of the package may have a bug, it's sometimes
4740 worth to give it a try and send me more specific output. You should
4741 know that "o debug" has built-in completion support.
4742
4743 =head2 Floppy, Zip, Offline Mode
4744
4745 CPAN.pm works nicely without network too. If you maintain machines
4746 that are not networked at all, you should consider working with file:
4747 URLs. Of course, you have to collect your modules somewhere first. So
4748 you might use CPAN.pm to put together all you need on a networked
4749 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
4750 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
4751 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
4752 with this floppy. See also below the paragraph about CD-ROM support.
4753
4754 =head1 CONFIGURATION
4755
4756 When the CPAN module is installed, a site wide configuration file is
4757 created as CPAN/Config.pm. The default values defined there can be
4758 overridden in another configuration file: CPAN/MyConfig.pm. You can
4759 store this file in $HOME/.cpan/CPAN/MyConfig.pm if you want, because
4760 $HOME/.cpan is added to the search path of the CPAN module before the
4761 use() or require() statements.
4762
4763 Currently the following keys in the hash reference $CPAN::Config are
4764 defined:
4765
4766   build_cache        size of cache for directories to build modules
4767   build_dir          locally accessible directory to build modules
4768   index_expire       after this many days refetch index files
4769   cpan_home          local directory reserved for this package
4770   gzip               location of external program gzip
4771   inactivity_timeout breaks interactive Makefile.PLs after this
4772                      many seconds inactivity. Set to 0 to never break.
4773   inhibit_startup_message
4774                      if true, does not print the startup message
4775   keep_source_where  directory in which to keep the source (if we do)
4776   make               location of external make program
4777   make_arg           arguments that should always be passed to 'make'
4778   make_install_arg   same as make_arg for 'make install'
4779   makepl_arg         arguments passed to 'perl Makefile.PL'
4780   pager              location of external program more (or any pager)
4781   prerequisites_policy
4782                      what to do if you are missing module prerequisites
4783                      ('follow' automatically, 'ask' me, or 'ignore')
4784   scan_cache         controls scanning of cache ('atstart' or 'never')
4785   tar                location of external program tar
4786   unzip              location of external program unzip
4787   urllist            arrayref to nearby CPAN sites (or equivalent locations)
4788   wait_list          arrayref to a wait server to try (See CPAN::WAIT)
4789   ftp_proxy,      }  the three usual variables for configuring
4790     http_proxy,   }  proxy requests. Both as CPAN::Config variables
4791     no_proxy      }  and as environment variables configurable.
4792
4793 You can set and query each of these options interactively in the cpan
4794 shell with the command set defined within the C<o conf> command:
4795
4796 =over 2
4797
4798 =item o conf E<lt>scalar optionE<gt>
4799
4800 prints the current value of the I<scalar option>
4801
4802 =item o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>
4803
4804 Sets the value of the I<scalar option> to I<value>
4805
4806 =item o conf E<lt>list optionE<gt>
4807
4808 prints the current value of the I<list option> in MakeMaker's
4809 neatvalue format.
4810
4811 =item o conf E<lt>list optionE<gt> [shift|pop]
4812
4813 shifts or pops the array in the I<list option> variable
4814
4815 =item o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>
4816
4817 works like the corresponding perl commands.
4818
4819 =back
4820
4821 =head2 Note on urllist parameter's format
4822
4823 urllist parameters are URLs according to RFC 1738. We do a little
4824 guessing if your URL is not compliant, but if you have problems with file URLs, please try the correct format. Either:
4825
4826     file://localhost/whatever/ftp/pub/CPAN/
4827
4828 or
4829
4830     file:///home/ftp/pub/CPAN/
4831
4832 =head2 urllist parameter has CD-ROM support
4833
4834 The C<urllist> parameter of the configuration table contains a list of
4835 URLs that are to be used for downloading. If the list contains any
4836 C<file> URLs, CPAN always tries to get files from there first. This
4837 feature is disabled for index files. So the recommendation for the
4838 owner of a CD-ROM with CPAN contents is: include your local, possibly
4839 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
4840
4841   o conf urllist push file://localhost/CDROM/CPAN
4842
4843 CPAN.pm will then fetch the index files from one of the CPAN sites
4844 that come at the beginning of urllist. It will later check for each
4845 module if there is a local copy of the most recent version.
4846
4847 Another peculiarity of urllist is that the site that we could
4848 successfully fetch the last file from automatically gets a preference
4849 token and is tried as the first site for the next request. So if you
4850 add a new site at runtime it may happen that the previously preferred
4851 site will be tried another time. This means that if you want to disallow
4852 a site for the next transfer, it must be explicitly removed from
4853 urllist.
4854
4855 =head1 SECURITY
4856
4857 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
4858 install foreign, unmasked, unsigned code on your machine. We compare
4859 to a checksum that comes from the net just as the distribution file
4860 itself. If somebody has managed to tamper with the distribution file,
4861 they may have as well tampered with the CHECKSUMS file. Future
4862 development will go towards strong authentication.
4863
4864 =head1 EXPORT
4865
4866 Most functions in package CPAN are exported per default. The reason
4867 for this is that the primary use is intended for the cpan shell or for
4868 oneliners.
4869
4870 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
4871
4872 To populate a freshly installed perl with my favorite modules is pretty
4873 easiest by maintaining a private bundle definition file. To get a useful
4874 blueprint of a bundle definition file, the command autobundle can be used
4875 on the CPAN shell command line. This command writes a bundle definition
4876 file for all modules that are installed for the currently running perl
4877 interpreter. It's recommended to run this command only once and from then
4878 on maintain the file manually under a private name, say
4879 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
4880
4881     cpan> install Bundle::my_bundle
4882
4883 then answer a few questions and then go out for a coffee.
4884
4885 Maintaining a bundle definition file means to keep track of two
4886 things: dependencies and interactivity. CPAN.pm sometimes fails on
4887 calculating dependencies because not all modules define all MakeMaker
4888 attributes correctly, so a bundle definition file should specify
4889 prerequisites as early as possible. On the other hand, it's a bit
4890 annoying that many distributions need some interactive configuring. So
4891 what I try to accomplish in my private bundle file is to have the
4892 packages that need to be configured early in the file and the gentle
4893 ones later, so I can go out after a few minutes and leave CPAN.pm
4894 unattained.
4895
4896 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
4897
4898 Thanks to Graham Barr for contributing the following paragraphs about
4899 the interaction between perl, and various firewall configurations.
4900
4901 Firewalls can be categorized into three basic types.
4902
4903 =over
4904
4905 =item http firewall
4906
4907 This is where the firewall machine runs a web server and to access the
4908 outside world you must do it via the web server. If you set environment
4909 variables like http_proxy or ftp_proxy to a values beginning with http://
4910 or in your web browser you have to set proxy information then you know
4911 you are running a http firewall.
4912
4913 To access servers outside these types of firewalls with perl (even for
4914 ftp) you will need to use LWP.
4915
4916 =item ftp firewall
4917
4918 This where the firewall machine runs a ftp server. This kind of firewall will
4919 only let you access ftp serves outside the firewall. This is usually done by
4920 connecting to the firewall with ftp, then entering a username like
4921 "user@outside.host.com"
4922
4923 To access servers outside these type of firewalls with perl you
4924 will need to use Net::FTP.
4925
4926 =item One way visibility
4927
4928 I say one way visibility as these firewalls try to make themselve look
4929 invisible to the users inside the firewall. An FTP data connection is
4930 normally created by sending the remote server your IP address and then
4931 listening for the connection. But the remote server will not be able to
4932 connect to you because of the firewall. So for these types of firewall
4933 FTP connections need to be done in a passive mode.
4934
4935 There are two that I can think off.
4936
4937 =over
4938
4939 =item SOCKS
4940
4941 If you are using a SOCKS firewall you will need to compile perl and link
4942 it with the SOCKS library, this is what is normally called a ``socksified''
4943 perl. With this executable you will be able to connect to servers outside
4944 the firewall as if it is not there.
4945
4946 =item IP Masquerade
4947
4948 This is the firewall implemented in the Linux kernel, it allows you to
4949 hide a complete network behind one IP address. With this firewall no
4950 special compiling is need as you can access hosts directly.
4951
4952 =back
4953
4954 =back
4955
4956 =head1 BUGS
4957
4958 We should give coverage for B<all> of the CPAN and not just the PAUSE
4959 part, right? In this discussion CPAN and PAUSE have become equal --
4960 but they are not. PAUSE is authors/ and modules/. CPAN is PAUSE plus
4961 the clpa/, doc/, misc/, ports/, src/, scripts/.
4962
4963 Future development should be directed towards a better integration of
4964 the other parts.
4965
4966 If a Makefile.PL requires special customization of libraries, prompts
4967 the user for special input, etc. then you may find CPAN is not able to
4968 build the distribution. In that case, you should attempt the
4969 traditional method of building a Perl module package from a shell.
4970
4971 =head1 AUTHOR
4972
4973 Andreas König E<lt>a.koenig@kulturbox.deE<gt>
4974
4975 =head1 SEE ALSO
4976
4977 perl(1), CPAN::Nox(3)
4978
4979 =cut
4980