lib/CPAN.pm

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