lib/CPAN.pm

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