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