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.56';
  10
  11 # $Id: CPAN.pm,v 1.303 2000/08/01 15:57:15 k Exp $
  12
  13 # only used during development:
  14 $Revision = "";
  15 # $Revision = "[".substr(q$Revision: 1.303 $, 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;
 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$|$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$}{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]");
 999         if ($o =~ /list$/) {
1000             $func = shift @args;
1001             $func ||= "";
1002             CPAN->debug("func[$func]");
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$//;
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) if $v & $CPAN::DEBUG;
1440             }
1441         } else {
1442             $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1443         }
1444     } else {
1445         $CPAN::Frontend->myprint(qq{
1446 Known options:
1447   conf    set or get configuration variables
1448   debug   set or get debugging options
1449 });
1450     }
1451 }
1452
1453 sub dotdot_onreload {
1454     my($ref) = shift;
1455     sub {
1456         if ( $_[0] =~ /Subroutine (\w+) redefined/ ) {
1457             my($subr) = $1;
1458             ++$$ref;
1459             local($|) = 1;
1460             # $CPAN::Frontend->myprint(".($subr)");
1461             $CPAN::Frontend->myprint(".");
1462             return;
1463         }
1464         warn @_;
1465     };
1466 }
1467
1468 #-> sub CPAN::Shell::reload ;
1469 sub reload {
1470     my($self,$command,@arg) = @_;
1471     $command ||= "";
1472     $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1473     if ($command =~ /cpan/i) {
1474         CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG;
1475         my $fh = FileHandle->new($INC{'CPAN.pm'});
1476         local($/);
1477         $redef = 0;
1478         local($SIG{__WARN__}) = dotdot_onreload(\$redef);
1479         eval <$fh>;
1480         warn $@ if $@;
1481         $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1482     } elsif ($command =~ /index/) {
1483       CPAN::Index->force_reload;
1484     } else {
1485       $CPAN::Frontend->myprint(qq{cpan     re-evals the CPAN.pm file
1486 index    re-reads the index files\n});
1487     }
1488 }
1489
1490 #-> sub CPAN::Shell::_binary_extensions ;
1491 sub _binary_extensions {
1492     my($self) = shift @_;
1493     my(@result,$module,%seen,%need,$headerdone);
1494     my $isaperl = q{ perl
1495                      -?
1496                      5[._-]
1497                      (
1498                       \\d{3}(_[0-4][0-9])?
1499                       |
1500                       \\d*[24680]\\.\\d+
1501                      )
1502                      \\.tar[._-]gz$
1503                     };
1504     for $module ($self->expand('Module','/./')) {
1505         my $file  = $module->cpan_file;
1506         next if $file eq "N/A";
1507         next if $file =~ /^Contact Author/;
1508         next if $file =~ / $isaperl /x;
1509         next unless $module->xs_file;
1510         local($|) = 1;
1511         $CPAN::Frontend->myprint(".");
1512         push @result, $module;
1513     }
1514 #    print join " | ", @result;
1515     $CPAN::Frontend->myprint("\n");
1516     return @result;
1517 }
1518
1519 #-> sub CPAN::Shell::recompile ;
1520 sub recompile {
1521     my($self) = shift @_;
1522     my($module,@module,$cpan_file,%dist);
1523     @module = $self->_binary_extensions();
1524     for $module (@module){  # we force now and compile later, so we
1525                             # don't do it twice
1526         $cpan_file = $module->cpan_file;
1527         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1528         $pack->force;
1529         $dist{$cpan_file}++;
1530     }
1531     for $cpan_file (sort keys %dist) {
1532         $CPAN::Frontend->myprint("  CPAN: Recompiling $cpan_file\n\n");
1533         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1534         $pack->install;
1535         $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1536                            # stop a package from recompiling,
1537                            # e.g. IO-1.12 when we have perl5.003_10
1538     }
1539 }
1540
1541 #-> sub CPAN::Shell::_u_r_common ;
1542 sub _u_r_common {
1543     my($self) = shift @_;
1544     my($what) = shift @_;
1545     CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
1546     Carp::croak "Usage: \$obj->_u_r_common($what)" unless defined $what;
1547     Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless $what =~ /^[aru]$/;
1548     my(@args) = @_;
1549     @args = '/./' unless @args;
1550     my(@result,$module,%seen,%need,$headerdone,
1551        $version_undefs,$version_zeroes);
1552     $version_undefs = $version_zeroes = 0;
1553     my $sprintf = "%-25s %9s %9s  %s\n";
1554     for $module ($self->expand('Module',@args)) {
1555         my $file  = $module->cpan_file;
1556         next unless defined $file; # ??
1557         my($latest) = $module->cpan_version;
1558         my($inst_file) = $module->inst_file;
1559         my($have);
1560         return if $CPAN::Signal;
1561         if ($inst_file){
1562             if ($what eq "a") {
1563                 $have = $module->inst_version;
1564             } elsif ($what eq "r") {
1565                 $have = $module->inst_version;
1566                 local($^W) = 0;
1567                 if ($have eq "undef"){
1568                     $version_undefs++;
1569                 } elsif ($have == 0){
1570                     $version_zeroes++;
1571                 }
1572                 next if $have >= $latest;
1573 # to be pedantic we should probably say:
1574 #    && !($have eq "undef" && $latest ne "undef" && $latest gt "");
1575 # to catch the case where CPAN has a version 0 and we have a version undef
1576             } elsif ($what eq "u") {
1577                 next;
1578             }
1579         } else {
1580             if ($what eq "a") {
1581                 next;
1582             } elsif ($what eq "r") {
1583                 next;
1584             } elsif ($what eq "u") {
1585                 $have = "-";
1586             }
1587         }
1588         return if $CPAN::Signal; # this is sometimes lengthy
1589         $seen{$file} ||= 0;
1590         if ($what eq "a") {
1591             push @result, sprintf "%s %s\n", $module->id, $have;
1592         } elsif ($what eq "r") {
1593             push @result, $module->id;
1594             next if $seen{$file}++;
1595         } elsif ($what eq "u") {
1596             push @result, $module->id;
1597             next if $seen{$file}++;
1598             next if $file =~ /^Contact/;
1599         }
1600         unless ($headerdone++){
1601             $CPAN::Frontend->myprint("\n");
1602             $CPAN::Frontend->myprint(sprintf(
1603                    $sprintf,
1604                    "Package namespace",
1605                    "installed",
1606                    "latest",
1607                    "in CPAN file"
1608                    ));
1609         }
1610         $latest = substr($latest,0,8) if length($latest) > 8;
1611         $have = substr($have,0,8) if length($have) > 8;
1612         $CPAN::Frontend->myprint(sprintf $sprintf, $module->id, $have, $latest, $file);
1613         $need{$module->id}++;
1614     }
1615     unless (%need) {
1616         if ($what eq "u") {
1617             $CPAN::Frontend->myprint("No modules found for @args\n");
1618         } elsif ($what eq "r") {
1619             $CPAN::Frontend->myprint("All modules are up to date for @args\n");
1620         }
1621     }
1622     if ($what eq "r") {
1623         if ($version_zeroes) {
1624             my $s_has = $version_zeroes > 1 ? "s have" : " has";
1625             $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
1626                 qq{a version number of 0\n});
1627         }
1628         if ($version_undefs) {
1629             my $s_has = $version_undefs > 1 ? "s have" : " has";
1630             $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
1631                 qq{parseable version number\n});
1632         }
1633     }
1634     @result;
1635 }
1636
1637 #-> sub CPAN::Shell::r ;
1638 sub r {
1639     shift->_u_r_common("r",@_);
1640 }
1641
1642 #-> sub CPAN::Shell::u ;
1643 sub u {
1644     shift->_u_r_common("u",@_);
1645 }
1646
1647 #-> sub CPAN::Shell::autobundle ;
1648 sub autobundle {
1649     my($self) = shift;
1650     CPAN::Config->load unless $CPAN::Config_loaded++;
1651     my(@bundle) = $self->_u_r_common("a",@_);
1652     my($todir) = MM->catdir($CPAN::Config->{'cpan_home'},"Bundle");
1653     File::Path::mkpath($todir);
1654     unless (-d $todir) {
1655         $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
1656         return;
1657     }
1658     my($y,$m,$d) =  (localtime)[5,4,3];
1659     $y+=1900;
1660     $m++;
1661     my($c) = 0;
1662     my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
1663     my($to) = MM->catfile($todir,"$me.pm");
1664     while (-f $to) {
1665         $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
1666         $to = MM->catfile($todir,"$me.pm");
1667     }
1668     my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
1669     $fh->print(
1670                "package Bundle::$me;\n\n",
1671                "\$VERSION = '0.01';\n\n",
1672                "1;\n\n",
1673                "__END__\n\n",
1674                "=head1 NAME\n\n",
1675                "Bundle::$me - Snapshot of installation on ",
1676                $Config::Config{'myhostname'},
1677                " on ",
1678                scalar(localtime),
1679                "\n\n=head1 SYNOPSIS\n\n",
1680                "perl -MCPAN -e 'install Bundle::$me'\n\n",
1681                "=head1 CONTENTS\n\n",
1682                join("\n", @bundle),
1683                "\n\n=head1 CONFIGURATION\n\n",
1684                Config->myconfig,
1685                "\n\n=head1 AUTHOR\n\n",
1686                "This Bundle has been generated automatically ",
1687                "by the autobundle routine in CPAN.pm.\n",
1688               );
1689     $fh->close;
1690     $CPAN::Frontend->myprint("\nWrote bundle file
1691     $to\n\n");
1692 }
1693
1694 #-> sub CPAN::Shell::expand ;
1695 sub expand {
1696     shift;
1697     my($type,@args) = @_;
1698     my($arg,@m);
1699     for $arg (@args) {
1700         my $regex;
1701         if ($arg =~ m|^/(.*)/$|) {
1702             $regex = $1;
1703         }
1704         my $class = "CPAN::$type";
1705         my $obj;
1706         if (defined $regex) {
1707           for $obj (
1708                     sort
1709                     {$a->id cmp $b->id}
1710                     $CPAN::META->all_objects($class)
1711                    ) {
1712             unless ($obj->id){
1713               # BUG, we got an empty object somewhere
1714               CPAN->debug(sprintf(
1715                                   "Empty id on obj[%s]%%[%s]",
1716                                   $obj,
1717                                   join(":", %$obj)
1718                                  )) if $CPAN::DEBUG;
1719               next;
1720             }
1721             push @m, $obj
1722                 if $obj->id =~ /$regex/i
1723                     or
1724                         (
1725                          (
1726                           $] < 5.00303 ### provide sort of
1727                                        ### compatibility with 5.003
1728                           ||
1729                           $obj->can('name')
1730                          )
1731                          &&
1732                          $obj->name  =~ /$regex/i
1733                         );
1734           }
1735         } else {
1736             my($xarg) = $arg;
1737             if ( $type eq 'Bundle' ) {
1738                 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
1739             }
1740             if ($CPAN::META->exists($class,$xarg)) {
1741                 $obj = $CPAN::META->instance($class,$xarg);
1742             } elsif ($CPAN::META->exists($class,$arg)) {
1743                 $obj = $CPAN::META->instance($class,$arg);
1744             } else {
1745                 next;
1746             }
1747             push @m, $obj;
1748         }
1749     }
1750     return wantarray ? @m : $m[0];
1751 }
1752
1753 #-> sub CPAN::Shell::format_result ;
1754 sub format_result {
1755     my($self) = shift;
1756     my($type,@args) = @_;
1757     @args = '/./' unless @args;
1758     my(@result) = $self->expand($type,@args);
1759     my $result =  @result == 1 ?
1760         $result[0]->as_string :
1761             join "", map {$_->as_glimpse} @result;
1762     $result ||= "No objects of type $type found for argument @args\n";
1763     $result;
1764 }
1765
1766 # The only reason for this method is currently to have a reliable
1767 # debugging utility that reveals which output is going through which
1768 # channel. No, I don't like the colors ;-)
1769 sub print_ornamented {
1770     my($self,$what,$ornament) = @_;
1771     my $longest = 0;
1772     my $ornamenting = 0; # turn the colors on
1773
1774     if ($ornamenting) {
1775         unless (defined &color) {
1776             if ($CPAN::META->has_inst("Term::ANSIColor")) {
1777                 import Term::ANSIColor "color";
1778             } else {
1779                 *color = sub { return "" };
1780             }
1781         }
1782         my $line;
1783         for $line (split /\n/, $what) {
1784             $longest = length($line) if length($line) > $longest;
1785         }
1786         my $sprintf = "%-" . $longest . "s";
1787         while ($what){
1788             $what =~ s/(.*\n?)//m;
1789             my $line = $1;
1790             last unless $line;
1791             my($nl) = chomp $line ? "\n" : "";
1792             #   print "line[$line]ornament[$ornament]sprintf[$sprintf]\n";
1793             print color($ornament), sprintf($sprintf,$line), color("reset"), $nl;
1794         }
1795     } else {
1796         print $what;
1797     }
1798 }
1799
1800 sub myprint {
1801     my($self,$what) = @_;
1802     $self->print_ornamented($what, 'bold blue on_yellow');
1803 }
1804
1805 sub myexit {
1806     my($self,$what) = @_;
1807     $self->myprint($what);
1808     exit;
1809 }
1810
1811 sub mywarn {
1812     my($self,$what) = @_;
1813     $self->print_ornamented($what, 'bold red on_yellow');
1814 }
1815
1816 sub myconfess {
1817     my($self,$what) = @_;
1818     $self->print_ornamented($what, 'bold red on_white');
1819     Carp::confess "died";
1820 }
1821
1822 sub mydie {
1823     my($self,$what) = @_;
1824     $self->print_ornamented($what, 'bold red on_white');
1825     die "\n";
1826 }
1827
1828 sub setup_output {
1829     return if -t STDOUT;
1830     my $odef = select STDERR;
1831     $| = 1;
1832     select STDOUT;
1833     $| = 1;
1834     select $odef;
1835 }
1836
1837 #-> sub CPAN::Shell::rematein ;
1838 # RE-adme||MA-ke||TE-st||IN-stall
1839 sub rematein {
1840     shift;
1841     my($meth,@some) = @_;
1842     my $pragma = "";
1843     if ($meth eq 'force') {
1844         $pragma = $meth;
1845         $meth = shift @some;
1846     }
1847     setup_output();
1848     CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG;
1849     my($s,@s);
1850     foreach $s (@some) {
1851       CPAN::Queue->new($s);
1852     }
1853     while ($s = CPAN::Queue->first) {
1854         my $obj;
1855         if (ref $s) {
1856             $obj = $s;
1857         } elsif ($s =~ m|/|) { # looks like a file
1858             $obj = $CPAN::META->instance('CPAN::Distribution',$s);
1859         } elsif ($s =~ m|^Bundle::|) {
1860             $obj = $CPAN::META->instance('CPAN::Bundle',$s);
1861         } else {
1862             $obj = $CPAN::META->instance('CPAN::Module',$s)
1863                 if $CPAN::META->exists('CPAN::Module',$s);
1864         }
1865         if (ref $obj) {
1866             CPAN->debug(
1867                         qq{pragma[$pragma]meth[$meth]obj[$obj]as_string\[}.
1868                         $obj->as_string.
1869                         qq{\]}
1870                        ) if $CPAN::DEBUG;
1871             $obj->$pragma()
1872                 if
1873                     $pragma
1874                         &&
1875                     ($] < 5.00303 || $obj->can($pragma)); ###
1876                                                           ### compatibility
1877                                                           ### with
1878                                                           ### 5.003
1879             if ($]>=5.00303 && $obj->can('called_for')) {
1880               $obj->called_for($s);
1881             }
1882             CPAN::Queue->delete($s) if $obj->$meth(); # if it is more
1883                                                       # than once in
1884                                                       # the queue
1885         } elsif ($CPAN::META->exists('CPAN::Author',$s)) {
1886             $obj = $CPAN::META->instance('CPAN::Author',$s);
1887             $CPAN::Frontend->myprint(
1888                                      join "",
1889                                      "Don't be silly, you can't $meth ",
1890                                      $obj->fullname,
1891                                      " ;-)\n"
1892                                     );
1893         } else {
1894             $CPAN::Frontend
1895                 ->myprint(qq{Warning: Cannot $meth $s, }.
1896                           qq{don\'t know what it is.
1897 Try the command
1898
1899     i /$s/
1900
1901 to find objects with similar identifiers.
1902 });
1903         }
1904         CPAN::Queue->delete_first($s);
1905     }
1906 }
1907
1908 #-> sub CPAN::Shell::force ;
1909 sub force   { shift->rematein('force',@_); }
1910 #-> sub CPAN::Shell::get ;
1911 sub get     { shift->rematein('get',@_); }
1912 #-> sub CPAN::Shell::readme ;
1913 sub readme  { shift->rematein('readme',@_); }
1914 #-> sub CPAN::Shell::make ;
1915 sub make    { shift->rematein('make',@_); }
1916 #-> sub CPAN::Shell::test ;
1917 sub test    { shift->rematein('test',@_); }
1918 #-> sub CPAN::Shell::install ;
1919 sub install { shift->rematein('install',@_); }
1920 #-> sub CPAN::Shell::clean ;
1921 sub clean   { shift->rematein('clean',@_); }
1922 #-> sub CPAN::Shell::look ;
1923 sub look   { shift->rematein('look',@_); }
1924 #-> sub CPAN::Shell::cvs_import ;
1925 sub cvs_import   { shift->rematein('cvs_import',@_); }
1926
1927 package CPAN::FTP;
1928
1929 #-> sub CPAN::FTP::ftp_get ;
1930 sub ftp_get {
1931   my($class,$host,$dir,$file,$target) = @_;
1932   $class->debug(
1933                 qq[Going to fetch file [$file] from dir [$dir]
1934         on host [$host] as local [$target]\n]
1935                       ) if $CPAN::DEBUG;
1936   my $ftp = Net::FTP->new($host);
1937   return 0 unless defined $ftp;
1938   $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
1939   $class->debug(qq[Going to ->login("anonymous","$Config::Config{'cf_email'}")\n]);
1940   unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
1941     warn "Couldn't login on $host";
1942     return;
1943   }
1944   unless ( $ftp->cwd($dir) ){
1945     warn "Couldn't cwd $dir";
1946     return;
1947   }
1948   $ftp->binary;
1949   $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
1950   unless ( $ftp->get($file,$target) ){
1951     warn "Couldn't fetch $file from $host\n";
1952     return;
1953   }
1954   $ftp->quit; # it's ok if this fails
1955   return 1;
1956 }
1957
1958 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
1959
1960  # leach,> *** /install/perl/live/lib/CPAN.pm-  Wed Sep 24 13:08:48 1997
1961  # leach,> --- /tmp/cp  Wed Sep 24 13:26:40 1997
1962  # leach,> ***************
1963  # leach,> *** 1562,1567 ****
1964  # leach,> --- 1562,1580 ----
1965  # leach,>       return 1 if substr($url,0,4) eq "file";
1966  # leach,>       return 1 unless $url =~ m|://([^/]+)|;
1967  # leach,>       my $host = $1;
1968  # leach,> +     my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
1969  # leach,> +     if ($proxy) {
1970  # leach,> +         $proxy =~ m|://([^/:]+)|;
1971  # leach,> +         $proxy = $1;
1972  # leach,> +         my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
1973  # leach,> +         if ($noproxy) {
1974  # leach,> +             if ($host !~ /$noproxy$/) {
1975  # leach,> +                 $host = $proxy;
1976  # leach,> +             }
1977  # leach,> +         } else {
1978  # leach,> +             $host = $proxy;
1979  # leach,> +         }
1980  # leach,> +     }
1981  # leach,>       require Net::Ping;
1982  # leach,>       return 1 unless $Net::Ping::VERSION >= 2;
1983  # leach,>       my $p;
1984
1985
1986 # this is quite optimistic and returns one on several occasions where
1987 # inappropriate. But this does no harm. It would do harm if we were
1988 # too pessimistic (as I was before the http_proxy
1989 sub is_reachable {
1990     my($self,$url) = @_;
1991     return 1; # we can't simply roll our own, firewalls may break ping
1992     return 0 unless $url;
1993     return 1 if substr($url,0,4) eq "file";
1994     return 1 unless $url =~ m|^(\w+)://([^/]+)|;
1995     my $proxytype = $1 . "_proxy"; # ftp_proxy or http_proxy
1996     my $host = $2;
1997     return 1 if $CPAN::Config->{$proxytype} || $ENV{$proxytype};
1998     require Net::Ping;
1999     return 1 unless $Net::Ping::VERSION >= 2;
2000     my $p;
2001     # 1.3101 had it different: only if the first eval raised an
2002     # exception we tried it with TCP. Now we are happy if icmp wins
2003     # the order and return, we don't even check for $@. Thanks to
2004     # thayer@uis.edu for the suggestion.
2005     eval {$p = Net::Ping->new("icmp");};
2006     return 1 if $p && ref($p) && $p->ping($host, 10);
2007     eval {$p = Net::Ping->new("tcp");};
2008     $CPAN::Frontend->mydie($@) if $@;
2009     return $p->ping($host, 10);
2010 }
2011
2012 #-> sub CPAN::FTP::localize ;
2013 # sorry for the ugly code here, I'll clean it up as soon as Net::FTP
2014 # is in the core
2015 sub localize {
2016     my($self,$file,$aslocal,$force) = @_;
2017     $force ||= 0;
2018     Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
2019         unless defined $aslocal;
2020     $self->debug("file[$file] aslocal[$aslocal] force[$force]")
2021         if $CPAN::DEBUG;
2022
2023     if ($^O eq 'MacOS') {
2024         my($name, $path) = File::Basename::fileparse($aslocal, '');
2025         if (length($name) > 31) {
2026             $name =~ s/(\.(readme(\.(gz|Z))?|(tar\.)?(gz|Z)|tgz|zip|pm\.(gz|Z)))$//;
2027             my $suf = $1;
2028             my $size = 31 - length($suf);
2029             while (length($name) > $size) {
2030                 chop $name;
2031             }
2032             $name .= $suf;
2033             $aslocal = File::Spec->catfile($path, $name);
2034         }
2035     }
2036
2037     return $aslocal if -f $aslocal && -r _ && !($force & 1);
2038     my($restore) = 0;
2039     if (-f $aslocal){
2040         rename $aslocal, "$aslocal.bak";
2041         $restore++;
2042     }
2043
2044     my($aslocal_dir) = File::Basename::dirname($aslocal);
2045     File::Path::mkpath($aslocal_dir);
2046     $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
2047         qq{directory "$aslocal_dir".
2048     I\'ll continue, but if you encounter problems, they may be due
2049     to insufficient permissions.\n}) unless -w $aslocal_dir;
2050
2051     # Inheritance is not easier to manage than a few if/else branches
2052     if ($CPAN::META->has_usable('LWP::UserAgent')) {
2053         unless ($Ua) {
2054             $Ua = LWP::UserAgent->new;
2055             my($var);
2056             $Ua->proxy('ftp',  $var)
2057                 if $var = $CPAN::Config->{'ftp_proxy'} || $ENV{'ftp_proxy'};
2058             $Ua->proxy('http', $var)
2059                 if $var = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
2060             $Ua->no_proxy($var)
2061                 if $var = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
2062         }
2063     }
2064
2065     # Try the list of urls for each single object. We keep a record
2066     # where we did get a file from
2067     my(@reordered,$last);
2068     $CPAN::Config->{urllist} ||= [];
2069     $last = $#{$CPAN::Config->{urllist}};
2070     if ($force & 2) { # local cpans probably out of date, don't reorder
2071         @reordered = (0..$last);
2072     } else {
2073         @reordered =
2074             sort {
2075                 (substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
2076                     <=>
2077                 (substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
2078                     or
2079                 defined($Thesite)
2080                     and
2081                 ($b == $Thesite)
2082                     <=>
2083                 ($a == $Thesite)
2084             } 0..$last;
2085     }
2086     my($level,@levels);
2087     if ($Themethod) {
2088         @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
2089     } else {
2090         @levels = qw/easy hard hardest/;
2091     }
2092     @levels = qw/easy/ if $^O eq 'MacOS';
2093     for $level (@levels) {
2094         my $method = "host$level";
2095         my @host_seq = $level eq "easy" ?
2096             @reordered : 0..$last;  # reordered has CDROM up front
2097         @host_seq = (0) unless @host_seq;
2098         my $ret = $self->$method(\@host_seq,$file,$aslocal);
2099         if ($ret) {
2100           $Themethod = $level;
2101           my $now = time;
2102           # utime $now, $now, $aslocal; # too bad, if we do that, we
2103                                       # might alter a local mirror
2104           $self->debug("level[$level]") if $CPAN::DEBUG;
2105           return $ret;
2106         } else {
2107           unlink $aslocal;
2108         }
2109     }
2110     my(@mess);
2111     push @mess,
2112     qq{Please check, if the URLs I found in your configuration file \(}.
2113         join(", ", @{$CPAN::Config->{urllist}}).
2114             qq{\) are valid. The urllist can be edited.},
2115             qq{E.g. with ``o conf urllist push ftp://myurl/''};
2116     $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
2117     sleep 2;
2118     $CPAN::Frontend->myprint("Cannot fetch $file\n\n");
2119     if ($restore) {
2120         rename "$aslocal.bak", $aslocal;
2121         $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
2122                                  $self->ls($aslocal));
2123         return $aslocal;
2124     }
2125     return;
2126 }
2127
2128 sub hosteasy {
2129     my($self,$host_seq,$file,$aslocal) = @_;
2130     my($i);
2131   HOSTEASY: for $i (@$host_seq) {
2132       my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2133         unless ($self->is_reachable($url)) {
2134             $CPAN::Frontend->myprint("Skipping $url (seems to be not reachable)\n");
2135             sleep 2;
2136             next;
2137         }
2138         $url .= "/" unless substr($url,-1) eq "/";
2139         $url .= $file;
2140         $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
2141         if ($url =~ /^file:/) {
2142             my $l;
2143             if ($CPAN::META->has_inst('URI::URL')) {
2144                 my $u =  URI::URL->new($url);
2145                 $l = $u->path;
2146             } else { # works only on Unix, is poorly constructed, but
2147                 # hopefully better than nothing.
2148                 # RFC 1738 says fileurl BNF is
2149                 # fileurl = "file://" [ host | "localhost" ] "/" fpath
2150                 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
2151                 # the code
2152                 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
2153                 $l =~ s|^file:||;                   # assume they
2154                                                     # meant
2155                                                     # file://localhost
2156                 $l =~ s|^/||s unless -f $l;         # e.g. /P:
2157             }
2158             if ( -f $l && -r _) {
2159                 $Thesite = $i;
2160                 return $l;
2161             }
2162             # Maybe mirror has compressed it?
2163             if (-f "$l.gz") {
2164                 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
2165                 CPAN::Tarzip->gunzip("$l.gz", $aslocal);
2166                 if ( -f $aslocal) {
2167                     $Thesite = $i;
2168                     return $aslocal;
2169                 }
2170             }
2171         }
2172       if ($CPAN::META->has_usable('LWP')) {
2173           $CPAN::Frontend->myprint("Fetching with LWP:
2174   $url
2175 ");
2176           unless ($Ua) {
2177             require LWP::UserAgent;
2178             $Ua = LWP::UserAgent->new;
2179           }
2180           my $res = $Ua->mirror($url, $aslocal);
2181           if ($res->is_success) {
2182             $Thesite = $i;
2183             my $now = time;
2184             utime $now, $now, $aslocal; # download time is more
2185                                         # important than upload time
2186             return $aslocal;
2187           } elsif ($url !~ /\.gz$/) {
2188             my $gzurl = "$url.gz";
2189             $CPAN::Frontend->myprint("Fetching with LWP:
2190   $gzurl
2191 ");
2192             $res = $Ua->mirror($gzurl, "$aslocal.gz");
2193             if ($res->is_success &&
2194                 CPAN::Tarzip->gunzip("$aslocal.gz",$aslocal)
2195                ) {
2196               $Thesite = $i;
2197               return $aslocal;
2198             } else {
2199               # next HOSTEASY ;
2200             }
2201           } else {
2202             # Alan Burlison informed me that in firewall envs Net::FTP
2203             # can still succeed where LWP fails. So we do not skip
2204             # Net::FTP anymore when LWP is available.
2205             # next HOSTEASY ;
2206           }
2207         } else {
2208           $self->debug("LWP not installed") if $CPAN::DEBUG;
2209         }
2210         if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2211             # that's the nice and easy way thanks to Graham
2212             my($host,$dir,$getfile) = ($1,$2,$3);
2213             if ($CPAN::META->has_usable('Net::FTP')) {
2214                 $dir =~ s|/+|/|g;
2215                 $CPAN::Frontend->myprint("Fetching with Net::FTP:
2216   $url
2217 ");
2218                 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
2219                              "aslocal[$aslocal]") if $CPAN::DEBUG;
2220                 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
2221                     $Thesite = $i;
2222                     return $aslocal;
2223                 }
2224                 if ($aslocal !~ /\.gz$/) {
2225                     my $gz = "$aslocal.gz";
2226                     $CPAN::Frontend->myprint("Fetching with Net::FTP
2227   $url.gz
2228 ");
2229                    if (CPAN::FTP->ftp_get($host,
2230                                            $dir,
2231                                            "$getfile.gz",
2232                                            $gz) &&
2233                         CPAN::Tarzip->gunzip($gz,$aslocal)
2234                        ){
2235                         $Thesite = $i;
2236                         return $aslocal;
2237                     }
2238                 }
2239                 # next HOSTEASY;
2240             }
2241         }
2242     }
2243 }
2244
2245 sub hosthard {
2246   my($self,$host_seq,$file,$aslocal) = @_;
2247
2248   # Came back if Net::FTP couldn't establish connection (or
2249   # failed otherwise) Maybe they are behind a firewall, but they
2250   # gave us a socksified (or other) ftp program...
2251
2252   my($i);
2253   my($devnull) = $CPAN::Config->{devnull} || "";
2254   # < /dev/null ";
2255   my($aslocal_dir) = File::Basename::dirname($aslocal);
2256   File::Path::mkpath($aslocal_dir);
2257   HOSTHARD: for $i (@$host_seq) {
2258         my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2259         unless ($self->is_reachable($url)) {
2260           $CPAN::Frontend->myprint("Skipping $url (not reachable)\n");
2261           next;
2262         }
2263         $url .= "/" unless substr($url,-1) eq "/";
2264         $url .= $file;
2265         my($proto,$host,$dir,$getfile);
2266
2267         # Courtesy Mark Conty mark_conty@cargill.com change from
2268         # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2269         # to
2270         if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
2271           # proto not yet used
2272           ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
2273         } else {
2274           next HOSTHARD; # who said, we could ftp anything except ftp?
2275         }
2276
2277         $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
2278         my($f,$funkyftp);
2279         for $f ('lynx','ncftpget','ncftp') {
2280           next unless exists $CPAN::Config->{$f};
2281           $funkyftp = $CPAN::Config->{$f};
2282           next unless defined $funkyftp;
2283           next if $funkyftp =~ /^\s*$/;
2284           my($asl_ungz, $asl_gz);
2285           ($asl_ungz = $aslocal) =~ s/\.gz//;
2286           $asl_gz = "$asl_ungz.gz";
2287           my($src_switch) = "";
2288           if ($f eq "lynx"){
2289             $src_switch = " -source";
2290           } elsif ($f eq "ncftp"){
2291             $src_switch = " -c";
2292           }
2293           my($chdir) = "";
2294           my($stdout_redir) = " > $asl_ungz";
2295           if ($f eq "ncftpget"){
2296             $chdir = "cd $aslocal_dir && ";
2297             $stdout_redir = "";
2298           }
2299           $CPAN::Frontend->myprint(
2300                                    qq[
2301 Trying with "$funkyftp$src_switch" to get
2302     $url
2303 ]);
2304           my($system) =
2305               "$chdir$funkyftp$src_switch '$url' $devnull$stdout_redir";
2306           $self->debug("system[$system]") if $CPAN::DEBUG;
2307           my($wstatus);
2308           if (($wstatus = system($system)) == 0
2309               &&
2310               ($f eq "lynx" ?
2311                -s $asl_ungz   # lynx returns 0 on my
2312                                           # system even if it fails
2313                : 1
2314               )
2315              ) {
2316             if (-s $aslocal) {
2317               # Looks good
2318             } elsif ($asl_ungz ne $aslocal) {
2319               # test gzip integrity
2320               if (
2321                   CPAN::Tarzip->gtest($asl_ungz)
2322                  ) {
2323                 rename $asl_ungz, $aslocal;
2324               } else {
2325                 CPAN::Tarzip->gzip($asl_ungz,$asl_gz);
2326               }
2327             }
2328             $Thesite = $i;
2329             return $aslocal;
2330           } elsif ($url !~ /\.gz$/) {
2331             unlink $asl_ungz if
2332                 -f $asl_ungz && -s _ == 0;
2333             my $gz = "$aslocal.gz";
2334             my $gzurl = "$url.gz";
2335             $CPAN::Frontend->myprint(
2336                                      qq[
2337 Trying with "$funkyftp$src_switch" to get
2338   $url.gz
2339 ]);
2340             my($system) = "$funkyftp$src_switch '$url.gz' $devnull > $asl_gz";
2341             $self->debug("system[$system]") if $CPAN::DEBUG;
2342             my($wstatus);
2343             if (($wstatus = system($system)) == 0
2344                 &&
2345                 -s $asl_gz
2346                ) {
2347               # test gzip integrity
2348               if (CPAN::Tarzip->gtest($asl_gz)) {
2349                 CPAN::Tarzip->gunzip($asl_gz,$aslocal);
2350               } else {
2351                 rename $asl_ungz, $aslocal;
2352               }
2353               $Thesite = $i;
2354               return $aslocal;
2355             } else {
2356               unlink $asl_gz if -f $asl_gz;
2357             }
2358           } else {
2359             my $estatus = $wstatus >> 8;
2360             my $size = -f $aslocal ?
2361                 ", left\n$aslocal with size ".-s _ :
2362                     "\nWarning: expected file [$aslocal] doesn't exist";
2363             $CPAN::Frontend->myprint(qq{
2364 System call "$system"
2365 returned status $estatus (wstat $wstatus)$size
2366 });
2367           }
2368         }
2369     }
2370 }
2371
2372 sub hosthardest {
2373     my($self,$host_seq,$file,$aslocal) = @_;
2374
2375     my($i);
2376     my($aslocal_dir) = File::Basename::dirname($aslocal);
2377     File::Path::mkpath($aslocal_dir);
2378   HOSTHARDEST: for $i (@$host_seq) {
2379         unless (length $CPAN::Config->{'ftp'}) {
2380             $CPAN::Frontend->myprint("No external ftp command available\n\n");
2381             last HOSTHARDEST;
2382         }
2383         my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2384         unless ($self->is_reachable($url)) {
2385             $CPAN::Frontend->myprint("Skipping $url (not reachable)\n");
2386             next;
2387         }
2388         $url .= "/" unless substr($url,-1) eq "/";
2389         $url .= $file;
2390         $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
2391         unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2392             next;
2393         }
2394         my($host,$dir,$getfile) = ($1,$2,$3);
2395         my $timestamp = 0;
2396         my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
2397            $ctime,$blksize,$blocks) = stat($aslocal);
2398         $timestamp = $mtime ||= 0;
2399         my($netrc) = CPAN::FTP::netrc->new;
2400         my($netrcfile) = $netrc->netrc;
2401         my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
2402         my $targetfile = File::Basename::basename($aslocal);
2403         my(@dialog);
2404         push(
2405              @dialog,
2406              "lcd $aslocal_dir",
2407              "cd /",
2408              map("cd $_", split "/", $dir), # RFC 1738
2409              "bin",
2410              "get $getfile $targetfile",
2411              "quit"
2412             );
2413         if (! $netrcfile) {
2414             CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
2415         } elsif ($netrc->hasdefault || $netrc->contains($host)) {
2416             CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
2417                                 $netrc->hasdefault,
2418                                 $netrc->contains($host))) if $CPAN::DEBUG;
2419             if ($netrc->protected) {
2420                 $CPAN::Frontend->myprint(qq{
2421   Trying with external ftp to get
2422     $url
2423   As this requires some features that are not thoroughly tested, we\'re
2424   not sure, that we get it right....
2425
2426 }
2427                      );
2428                 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose $host",
2429                                 @dialog);
2430                 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2431                  $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2432                 $mtime ||= 0;
2433                 if ($mtime > $timestamp) {
2434                     $CPAN::Frontend->myprint("GOT $aslocal\n");
2435                     $Thesite = $i;
2436                     return $aslocal;
2437                 } else {
2438                     $CPAN::Frontend->myprint("Hmm... Still failed!\n");
2439                 }
2440             } else {
2441                 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
2442                                         qq{correctly protected.\n});
2443             }
2444         } else {
2445             $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
2446   nor does it have a default entry\n");
2447         }
2448
2449         # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
2450         # then and login manually to host, using e-mail as
2451         # password.
2452         $CPAN::Frontend->myprint(qq{Issuing "$CPAN::Config->{'ftp'}$verbose -n"\n});
2453         unshift(
2454                 @dialog,
2455                 "open $host",
2456                 "user anonymous $Config::Config{'cf_email'}"
2457                );
2458         $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose -n", @dialog);
2459         ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2460          $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2461         $mtime ||= 0;
2462         if ($mtime > $timestamp) {
2463             $CPAN::Frontend->myprint("GOT $aslocal\n");
2464             $Thesite = $i;
2465             return $aslocal;
2466         } else {
2467             $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
2468         }
2469         $CPAN::Frontend->myprint("Can't access URL $url.\n\n");
2470         sleep 2;
2471     }
2472 }
2473
2474 sub talk_ftp {
2475     my($self,$command,@dialog) = @_;
2476     my $fh = FileHandle->new;
2477     $fh->open("|$command") or die "Couldn't open ftp: $!";
2478     foreach (@dialog) { $fh->print("$_\n") }
2479     $fh->close;         # Wait for process to complete
2480     my $wstatus = $?;
2481     my $estatus = $wstatus >> 8;
2482     $CPAN::Frontend->myprint(qq{
2483 Subprocess "|$command"
2484   returned status $estatus (wstat $wstatus)
2485 }) if $wstatus;
2486 }
2487
2488 # find2perl needs modularization, too, all the following is stolen
2489 # from there
2490 # CPAN::FTP::ls
2491 sub ls {
2492     my($self,$name) = @_;
2493     my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
2494      $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
2495
2496     my($perms,%user,%group);
2497     my $pname = $name;
2498
2499     if ($blocks) {
2500         $blocks = int(($blocks + 1) / 2);
2501     }
2502     else {
2503         $blocks = int(($sizemm + 1023) / 1024);
2504     }
2505
2506     if    (-f _) { $perms = '-'; }
2507     elsif (-d _) { $perms = 'd'; }
2508     elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
2509     elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
2510     elsif (-p _) { $perms = 'p'; }
2511     elsif (-S _) { $perms = 's'; }
2512     else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
2513
2514     my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
2515     my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
2516     my $tmpmode = $mode;
2517     my $tmp = $rwx[$tmpmode & 7];
2518     $tmpmode >>= 3;
2519     $tmp = $rwx[$tmpmode & 7] . $tmp;
2520     $tmpmode >>= 3;
2521     $tmp = $rwx[$tmpmode & 7] . $tmp;
2522     substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
2523     substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
2524     substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
2525     $perms .= $tmp;
2526
2527     my $user = $user{$uid} || $uid;   # too lazy to implement lookup
2528     my $group = $group{$gid} || $gid;
2529
2530     my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
2531     my($timeyear);
2532     my($moname) = $moname[$mon];
2533     if (-M _ > 365.25 / 2) {
2534         $timeyear = $year + 1900;
2535     }
2536     else {
2537         $timeyear = sprintf("%02d:%02d", $hour, $min);
2538     }
2539
2540     sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
2541             $ino,
2542                  $blocks,
2543                       $perms,
2544                             $nlink,
2545                                 $user,
2546                                      $group,
2547                                           $sizemm,
2548                                               $moname,
2549                                                  $mday,
2550                                                      $timeyear,
2551                                                          $pname;
2552 }
2553
2554 package CPAN::FTP::netrc;
2555
2556 sub new {
2557     my($class) = @_;
2558     my $file = MM->catfile($ENV{HOME},".netrc");
2559
2560     my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2561        $atime,$mtime,$ctime,$blksize,$blocks)
2562         = stat($file);
2563     $mode ||= 0;
2564     my $protected = 0;
2565
2566     my($fh,@machines,$hasdefault);
2567     $hasdefault = 0;
2568     $fh = FileHandle->new or die "Could not create a filehandle";
2569
2570     if($fh->open($file)){
2571         $protected = ($mode & 077) == 0;
2572         local($/) = "";
2573       NETRC: while (<$fh>) {
2574             my(@tokens) = split " ", $_;
2575           TOKEN: while (@tokens) {
2576                 my($t) = shift @tokens;
2577                 if ($t eq "default"){
2578                     $hasdefault++;
2579                     last NETRC;
2580                 }
2581                 last TOKEN if $t eq "macdef";
2582                 if ($t eq "machine") {
2583                     push @machines, shift @tokens;
2584                 }
2585             }
2586         }
2587     } else {
2588         $file = $hasdefault = $protected = "";
2589     }
2590
2591     bless {
2592            'mach' => [@machines],
2593            'netrc' => $file,
2594            'hasdefault' => $hasdefault,
2595            'protected' => $protected,
2596           }, $class;
2597 }
2598
2599 sub hasdefault { shift->{'hasdefault'} }
2600 sub netrc      { shift->{'netrc'}      }
2601 sub protected  { shift->{'protected'}  }
2602 sub contains {
2603     my($self,$mach) = @_;
2604     for ( @{$self->{'mach'}} ) {
2605         return 1 if $_ eq $mach;
2606     }
2607     return 0;
2608 }
2609
2610 package CPAN::Complete;
2611
2612 sub gnu_cpl {
2613     my($text, $line, $start, $end) = @_;
2614     my(@perlret) = cpl($text, $line, $start);
2615     # find longest common match. Can anybody show me how to peruse
2616     # T::R::Gnu to have this done automatically? Seems expensive.
2617     return () unless @perlret;
2618     my($newtext) = $text;
2619     for (my $i = length($text)+1;;$i++) {
2620         last unless length($perlret[0]) && length($perlret[0]) >= $i;
2621         my $try = substr($perlret[0],0,$i);
2622         my @tries = grep {substr($_,0,$i) eq $try} @perlret;
2623         # warn "try[$try]tries[@tries]";
2624         if (@tries == @perlret) {
2625             $newtext = $try;
2626         } else {
2627             last;
2628         }
2629     }
2630     ($newtext,@perlret);
2631 }
2632
2633 #-> sub CPAN::Complete::cpl ;
2634 sub cpl {
2635     my($word,$line,$pos) = @_;
2636     $word ||= "";
2637     $line ||= "";
2638     $pos ||= 0;
2639     CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2640     $line =~ s/^\s*//;
2641     if ($line =~ s/^(force\s*)//) {
2642         $pos -= length($1);
2643     }
2644     my @return;
2645     if ($pos == 0) {
2646         @return = grep(
2647                        /^$word/,
2648                        sort qw(
2649                                ! a b d h i m o q r u autobundle clean
2650                                make test install force reload look cvs_import
2651                               )
2652                       );
2653     } elsif ( $line !~ /^[\!abcdhimorutl]/ ) {
2654         @return = ();
2655     } elsif ($line =~ /^a\s/) {
2656         @return = cplx('CPAN::Author',$word);
2657     } elsif ($line =~ /^b\s/) {
2658         @return = cplx('CPAN::Bundle',$word);
2659     } elsif ($line =~ /^d\s/) {
2660         @return = cplx('CPAN::Distribution',$word);
2661     } elsif ($line =~ /^([mru]|make|clean|test|install|readme|look|cvs_import)\s/ ) {
2662         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
2663     } elsif ($line =~ /^i\s/) {
2664         @return = cpl_any($word);
2665     } elsif ($line =~ /^reload\s/) {
2666         @return = cpl_reload($word,$line,$pos);
2667     } elsif ($line =~ /^o\s/) {
2668         @return = cpl_option($word,$line,$pos);
2669     } else {
2670         @return = ();
2671     }
2672     return @return;
2673 }
2674
2675 #-> sub CPAN::Complete::cplx ;
2676 sub cplx {
2677     my($class, $word) = @_;
2678     # I believed for many years that this was sorted, today I
2679     # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
2680     # make it sorted again. Maybe sort was dropped when GNU-readline
2681     # support came in? The RCS file is difficult to read on that:-(
2682     sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
2683 }
2684
2685 #-> sub CPAN::Complete::cpl_any ;
2686 sub cpl_any {
2687     my($word) = shift;
2688     return (
2689             cplx('CPAN::Author',$word),
2690             cplx('CPAN::Bundle',$word),
2691             cplx('CPAN::Distribution',$word),
2692             cplx('CPAN::Module',$word),
2693            );
2694 }
2695
2696 #-> sub CPAN::Complete::cpl_reload ;
2697 sub cpl_reload {
2698     my($word,$line,$pos) = @_;
2699     $word ||= "";
2700     my(@words) = split " ", $line;
2701     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2702     my(@ok) = qw(cpan index);
2703     return @ok if @words == 1;
2704     return grep /^\Q$word\E/, @ok if @words == 2 && $word;
2705 }
2706
2707 #-> sub CPAN::Complete::cpl_option ;
2708 sub cpl_option {
2709     my($word,$line,$pos) = @_;
2710     $word ||= "";
2711     my(@words) = split " ", $line;
2712     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2713     my(@ok) = qw(conf debug);
2714     return @ok if @words == 1;
2715     return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
2716     if (0) {
2717     } elsif ($words[1] eq 'index') {
2718         return ();
2719     } elsif ($words[1] eq 'conf') {
2720         return CPAN::Config::cpl(@_);
2721     } elsif ($words[1] eq 'debug') {
2722         return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all';
2723     }
2724 }
2725
2726 package CPAN::Index;
2727
2728 #-> sub CPAN::Index::force_reload ;
2729 sub force_reload {
2730     my($class) = @_;
2731     $CPAN::Index::last_time = 0;
2732     $class->reload(1);
2733 }
2734
2735 #-> sub CPAN::Index::reload ;
2736 sub reload {
2737     my($cl,$force) = @_;
2738     my $time = time;
2739
2740     # XXX check if a newer one is available. (We currently read it
2741     # from time to time)
2742     for ($CPAN::Config->{index_expire}) {
2743         $_ = 0.001 unless $_ && $_ > 0.001;
2744     }
2745     return if $last_time + $CPAN::Config->{index_expire}*86400 > $time
2746         and ! $force;
2747     ## IFF we are developing, it helps to wipe out the memory between
2748     ## reloads, otherwise it is not what a user expects.
2749
2750     ## undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
2751     ## $CPAN::META = CPAN->new;
2752     my($debug,$t2);
2753     $last_time = $time;
2754
2755     my $needshort = $^O eq "dos";
2756
2757     $cl->rd_authindex($cl
2758                       ->reload_x(
2759                                  "authors/01mailrc.txt.gz",
2760                                  $needshort ?
2761                                  File::Spec->catfile('authors', '01mailrc.gz') :
2762                                  File::Spec->catfile('authors', '01mailrc.txt.gz'),
2763                                  $force));
2764     $t2 = time;
2765     $debug = "timing reading 01[".($t2 - $time)."]";
2766     $time = $t2;
2767     return if $CPAN::Signal; # this is sometimes lengthy
2768     $cl->rd_modpacks($cl
2769                      ->reload_x(
2770                                 "modules/02packages.details.txt.gz",
2771                                 $needshort ?
2772                                 File::Spec->catfile('modules', '02packag.gz') :
2773                                 File::Spec->catfile('modules', '02packages.details.txt.gz'),
2774                                 $force));
2775     $t2 = time;
2776     $debug .= "02[".($t2 - $time)."]";
2777     $time = $t2;
2778     return if $CPAN::Signal; # this is sometimes lengthy
2779     $cl->rd_modlist($cl
2780                     ->reload_x(
2781                                "modules/03modlist.data.gz",
2782                                $needshort ?
2783                                File::Spec->catfile('modules', '03mlist.gz') :
2784                                File::Spec->catfile('modules', '03modlist.data.gz'),
2785                                $force));
2786     $t2 = time;
2787     $debug .= "03[".($t2 - $time)."]";
2788     $time = $t2;
2789     CPAN->debug($debug) if $CPAN::DEBUG;
2790 }
2791
2792 #-> sub CPAN::Index::reload_x ;
2793 sub reload_x {
2794     my($cl,$wanted,$localname,$force) = @_;
2795     $force |= 2; # means we're dealing with an index here
2796     CPAN::Config->load; # we should guarantee loading wherever we rely
2797                         # on Config XXX
2798     $localname ||= $wanted;
2799     my $abs_wanted = MM->catfile($CPAN::Config->{'keep_source_where'},
2800                                    $localname);
2801     if (
2802         -f $abs_wanted &&
2803         -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
2804         !($force & 1)
2805        ) {
2806         my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
2807         $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
2808                    qq{day$s. I\'ll use that.});
2809         return $abs_wanted;
2810     } else {
2811         $force |= 1; # means we're quite serious about it.
2812     }
2813     return CPAN::FTP->localize($wanted,$abs_wanted,$force);
2814 }
2815
2816 #-> sub CPAN::Index::rd_authindex ;
2817 sub rd_authindex {
2818     my($cl, $index_target) = @_;
2819     my @lines;
2820     return unless defined $index_target;
2821     $CPAN::Frontend->myprint("Going to read $index_target\n");
2822 #    my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
2823 #    while ($_ = $fh->READLINE) {
2824     # no strict 'refs';
2825     local(*FH);
2826     tie *FH, CPAN::Tarzip, $index_target;
2827     local($/) = "\n";
2828     push @lines, split /\012/ while <FH>;
2829     foreach (@lines) {
2830         my($userid,$fullname,$email) =
2831             m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
2832         next unless $userid && $fullname && $email;
2833
2834         # instantiate an author object
2835         my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
2836         $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
2837         return if $CPAN::Signal;
2838     }
2839 }
2840
2841 sub userid {
2842   my($self,$dist) = @_;
2843   $dist = $self->{'id'} unless defined $dist;
2844   my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
2845   $ret;
2846 }
2847
2848 #-> sub CPAN::Index::rd_modpacks ;
2849 sub rd_modpacks {
2850     my($cl, $index_target) = @_;
2851     my @lines;
2852     return unless defined $index_target;
2853     $CPAN::Frontend->myprint("Going to read $index_target\n");
2854     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
2855     local($/) = "\n";
2856     while ($_ = $fh->READLINE) {
2857         s/\012/\n/g;
2858         my @ls = map {"$_\n"} split /\n/, $_;
2859         unshift @ls, "\n" x length($1) if /^(\n+)/;
2860         push @lines, @ls;
2861     }
2862     # read header
2863     my $line_count;
2864     while (@lines) {
2865         my $shift = shift(@lines);
2866         $shift =~ /^Line-Count:\s+(\d+)/;
2867         $line_count = $1 if $1;
2868         last if $shift =~ /^\s*$/;
2869     }
2870     if (not defined $line_count) {
2871         warn qq{Warning: Your $index_target does not contain a Line-Count header.
2872 Please check the validity of the index file by comparing it to more than one CPAN
2873 mirror. I'll continue but problems seem likely to happen.\a
2874 };
2875         sleep 5;
2876     } elsif ($line_count != scalar @lines) {
2877
2878         warn sprintf qq{Warning: Your %s
2879 contains a Line-Count header of %d but I see %d lines there. Please
2880 check the validity of the index file by comparing it to more than one
2881 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
2882 $index_target, $line_count, scalar(@lines);
2883
2884     }
2885     foreach (@lines) {
2886         chomp;
2887         my($mod,$version,$dist) = split;
2888 ###     $version =~ s/^\+//;
2889
2890         # if it is a bundle, instantiate a bundle object
2891         my($bundle,$id,$userid);
2892
2893         if ($mod eq 'CPAN' &&
2894             ! (
2895                CPAN::Queue->exists('Bundle::CPAN') ||
2896                CPAN::Queue->exists('CPAN')
2897               )
2898            ) {
2899             local($^W)= 0;
2900             if ($version > $CPAN::VERSION){
2901                 $CPAN::Frontend->myprint(qq{
2902   There\'s a new CPAN.pm version (v$version) available!
2903   [Current version is v$CPAN::VERSION]
2904   You might want to try
2905     install Bundle::CPAN
2906     reload cpan
2907   without quitting the current session. It should be a seamless upgrade
2908   while we are running...
2909 });
2910                 sleep 2;
2911                 $CPAN::Frontend->myprint(qq{\n});
2912             }
2913             last if $CPAN::Signal;
2914         } elsif ($mod =~ /^Bundle::(.*)/) {
2915             $bundle = $1;
2916         }
2917
2918         if ($bundle){
2919             $id =  $CPAN::META->instance('CPAN::Bundle',$mod);
2920             # warn "made mod[$mod]a bundle";
2921             # Let's make it a module too, because bundles have so much
2922             # in common with modules
2923             $CPAN::META->instance('CPAN::Module',$mod);
2924             # warn "made mod[$mod]a module";
2925
2926 # This "next" makes us faster but if the job is running long, we ignore
2927 # rereads which is bad. So we have to be a bit slower again.
2928 #       } elsif ($CPAN::META->exists('CPAN::Module',$mod)) {
2929 #           next;
2930
2931         }
2932         else {
2933             # instantiate a module object
2934             $id = $CPAN::META->instance('CPAN::Module',$mod);
2935         }
2936
2937         if ($id->cpan_file ne $dist){
2938             $userid = $cl->userid($dist);
2939             $id->set(
2940                      'CPAN_USERID' => $userid,
2941                      'CPAN_VERSION' => $version,
2942                      'CPAN_FILE' => $dist
2943                     );
2944         }
2945
2946         # instantiate a distribution object
2947         if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
2948           # we do not need CONTAINSMODS unless we do something with
2949           # this dist, so we better produce it on demand.
2950
2951           ## my $obj = $CPAN::META->instance(
2952           ##                              'CPAN::Distribution' => $dist
2953           ##                             );
2954           ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
2955         } else {
2956           $CPAN::META->instance(
2957                                 'CPAN::Distribution' => $dist
2958                                )->set(
2959                                       'CPAN_USERID' => $userid
2960                                      );
2961         }
2962
2963         return if $CPAN::Signal;
2964     }
2965     undef $fh;
2966 }
2967
2968 #-> sub CPAN::Index::rd_modlist ;
2969 sub rd_modlist {
2970     my($cl,$index_target) = @_;
2971     return unless defined $index_target;
2972     $CPAN::Frontend->myprint("Going to read $index_target\n");
2973     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
2974     my @eval;
2975     local($/) = "\n";
2976     while ($_ = $fh->READLINE) {
2977         s/\012/\n/g;
2978         my @ls = map {"$_\n"} split /\n/, $_;
2979         unshift @ls, "\n" x length($1) if /^(\n+)/;
2980         push @eval, @ls;
2981     }
2982     while (@eval) {
2983         my $shift = shift(@eval);
2984         if ($shift =~ /^Date:\s+(.*)/){
2985             return if $date_of_03 eq $1;
2986             ($date_of_03) = $1;
2987         }
2988         last if $shift =~ /^\s*$/;
2989     }
2990     undef $fh;
2991     push @eval, q{CPAN::Modulelist->data;};
2992     local($^W) = 0;
2993     my($comp) = Safe->new("CPAN::Safe1");
2994     my($eval) = join("", @eval);
2995     my $ret = $comp->reval($eval);
2996     Carp::confess($@) if $@;
2997     return if $CPAN::Signal;
2998     for (keys %$ret) {
2999         my $obj = $CPAN::META->instance(CPAN::Module,$_);
3000         $obj->set(%{$ret->{$_}});
3001         return if $CPAN::Signal;
3002     }
3003 }
3004
3005 package CPAN::InfoObj;
3006
3007 #-> sub CPAN::InfoObj::new ;
3008 sub new { my $this = bless {}, shift; %$this = @_; $this }
3009
3010 #-> sub CPAN::InfoObj::set ;
3011 sub set {
3012     my($self,%att) = @_;
3013     my(%oldatt) = %$self;
3014     %$self = (%oldatt, %att);
3015 }
3016
3017 #-> sub CPAN::InfoObj::id ;
3018 sub id { shift->{'ID'} }
3019
3020 #-> sub CPAN::InfoObj::as_glimpse ;
3021 sub as_glimpse {
3022     my($self) = @_;
3023     my(@m);
3024     my $class = ref($self);
3025     $class =~ s/^CPAN:://;
3026     push @m, sprintf "%-15s %s\n", $class, $self->{ID};
3027     join "", @m;
3028 }
3029
3030 #-> sub CPAN::InfoObj::as_string ;
3031 sub as_string {
3032     my($self) = @_;
3033     my(@m);
3034     my $class = ref($self);
3035     $class =~ s/^CPAN:://;
3036     push @m, $class, " id = $self->{ID}\n";
3037     for (sort keys %$self) {
3038         next if $_ eq 'ID';
3039         my $extra = "";
3040         if ($_ eq "CPAN_USERID") {
3041           $extra .= " (".$self->author;
3042           my $email; # old perls!
3043           if ($email = $CPAN::META->instance(CPAN::Author,
3044                                                 $self->{$_}
3045                                                )->email) {
3046             $extra .= " <$email>";
3047           } else {
3048             $extra .= " <no email>";
3049           }
3050           $extra .= ")";
3051         }
3052         if (ref($self->{$_}) eq "ARRAY") { # language interface? XXX
3053           push @m, sprintf "    %-12s %s%s\n", $_, "@{$self->{$_}}", $extra;
3054         } elsif (ref($self->{$_}) eq "HASH") {
3055           push @m, sprintf(
3056                            "    %-12s %s%s\n",
3057                            $_,
3058                            join(" ",keys %{$self->{$_}}),
3059                            $extra);
3060         } else {
3061           push @m, sprintf "    %-12s %s%s\n", $_, $self->{$_}, $extra;
3062         }
3063     }
3064     join "", @m, "\n";
3065 }
3066
3067 #-> sub CPAN::InfoObj::author ;
3068 sub author {
3069     my($self) = @_;
3070     $CPAN::META->instance(CPAN::Author,$self->{CPAN_USERID})->fullname;
3071 }
3072
3073 sub dump {
3074   my($self) = @_;
3075   require Data::Dumper;
3076   Data::Dumper::Dumper($self);
3077 }
3078
3079 package CPAN::Author;
3080
3081 #-> sub CPAN::Author::as_glimpse ;
3082 sub as_glimpse {
3083     my($self) = @_;
3084     my(@m);
3085     my $class = ref($self);
3086     $class =~ s/^CPAN:://;
3087     push @m, sprintf "%-15s %s (%s)\n", $class, $self->{ID}, $self->fullname;
3088     join "", @m;
3089 }
3090
3091 # Dead code, I would have liked to have,,, but it was never reached,,,
3092 #sub make {
3093 #    my($self) = @_;
3094 #    return "Don't be silly, you can't make $self->{FULLNAME} ;-)\n";
3095 #}
3096
3097 #-> sub CPAN::Author::fullname ;
3098 sub fullname { shift->{'FULLNAME'} }
3099 *name = \&fullname;
3100
3101 #-> sub CPAN::Author::email ;
3102 sub email    { shift->{'EMAIL'} }
3103
3104 package CPAN::Distribution;
3105
3106 #-> sub CPAN::Distribution::as_string ;
3107 sub as_string {
3108   my $self = shift;
3109   $self->containsmods;
3110   $self->SUPER::as_string(@_);
3111 }
3112
3113 #-> sub CPAN::Distribution::containsmods ;
3114 sub containsmods {
3115   my $self = shift;
3116   return if exists $self->{CONTAINSMODS};
3117   for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
3118     my $mod_file = $mod->{CPAN_FILE} or next;
3119     my $dist_id = $self->{ID} or next;
3120     my $mod_id = $mod->{ID} or next;
3121     $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
3122   }
3123 }
3124
3125 #-> sub CPAN::Distribution::called_for ;
3126 sub called_for {
3127     my($self,$id) = @_;
3128     $self->{'CALLED_FOR'} = $id if defined $id;
3129     return $self->{'CALLED_FOR'};
3130 }
3131
3132 #-> sub CPAN::Distribution::get ;
3133 sub get {
3134     my($self) = @_;
3135   EXCUSE: {
3136         my @e;
3137         exists $self->{'build_dir'} and push @e,
3138             "Unwrapped into directory $self->{'build_dir'}";
3139         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
3140     }
3141     my($local_file);
3142     my($local_wanted) =
3143          MM->catfile(
3144                         $CPAN::Config->{keep_source_where},
3145                         "authors",
3146                         "id",
3147                         split("/",$self->{ID})
3148                        );
3149
3150     $self->debug("Doing localize") if $CPAN::DEBUG;
3151     $local_file =
3152         CPAN::FTP->localize("authors/id/$self->{ID}", $local_wanted)
3153             or $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n");
3154     $self->{localfile} = $local_file;
3155     my $builddir = $CPAN::META->{cachemgr}->dir;
3156     $self->debug("doing chdir $builddir") if $CPAN::DEBUG;
3157     chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
3158     my $packagedir;
3159
3160     $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
3161     if ($CPAN::META->has_inst('MD5')) {
3162         $self->debug("MD5 is installed, verifying");
3163         $self->verifyMD5;
3164     } else {
3165         $self->debug("MD5 is NOT installed");
3166     }
3167     $self->debug("Removing tmp") if $CPAN::DEBUG;
3168     File::Path::rmtree("tmp");
3169     mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
3170     chdir "tmp";
3171     $self->debug("Changed directory to tmp") if $CPAN::DEBUG;
3172     if (! $local_file) {
3173         Carp::croak "bad download, can't do anything :-(\n";
3174     } elsif ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)$/i){
3175         $self->untar_me($local_file);
3176     } elsif ( $local_file =~ /\.zip$/i ) {
3177         $self->unzip_me($local_file);
3178     } elsif ( $local_file =~ /\.pm\.(gz|Z)$/) {
3179         $self->pm2dir_me($local_file);
3180     } else {
3181         $self->{archived} = "NO";
3182     }
3183     chdir File::Spec->updir;
3184     if ($self->{archived} ne 'NO') {
3185         chdir File::Spec->catdir(File::Spec->curdir, "tmp");
3186         # Let's check if the package has its own directory.
3187         my $dh = DirHandle->new(File::Spec->curdir)
3188             or Carp::croak("Couldn't opendir .: $!");
3189         my @readdir = grep $_ !~ /^\.\.?$/s, $dh->read; ### MAC??
3190         $dh->close;
3191         my ($distdir,$packagedir);
3192         if (@readdir == 1 && -d $readdir[0]) {
3193             $distdir = $readdir[0];
3194             $packagedir = MM->catdir($builddir,$distdir);
3195             -d $packagedir and $CPAN::Frontend->myprint("Removing previously used $packagedir\n");
3196             File::Path::rmtree($packagedir);
3197             rename($distdir,$packagedir) or Carp::confess("Couldn't rename $distdir to $packagedir: $!");
3198         } else {
3199             my $pragmatic_dir = $self->{'CPAN_USERID'} . '000';
3200             $pragmatic_dir =~ s/\W_//g;
3201             $pragmatic_dir++ while -d "../$pragmatic_dir";
3202             $packagedir = MM->catdir($builddir,$pragmatic_dir);
3203             File::Path::mkpath($packagedir);
3204             my($f);
3205             for $f (@readdir) { # is already without "." and ".."
3206                 my $to = MM->catdir($packagedir,$f);
3207                 rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
3208             }
3209         }
3210         $self->{'build_dir'} = $packagedir;
3211         chdir File::Spec->updir;
3212
3213         $self->debug("Changed directory to .. (self is $self [".$self->as_string."])")
3214             if $CPAN::DEBUG;
3215         File::Path::rmtree("tmp");
3216         if ($CPAN::Config->{keep_source_where} =~ /^no/i ){
3217             $CPAN::Frontend->myprint("Going to unlink $local_file\n");
3218             unlink $local_file or Carp::carp "Couldn't unlink $local_file";
3219         }
3220         my($makefilepl) = MM->catfile($packagedir,"Makefile.PL");
3221         unless (-f $makefilepl) {
3222           my($configure) = MM->catfile($packagedir,"Configure");
3223           if (-f $configure) {
3224             # do we have anything to do?
3225             $self->{'configure'} = $configure;
3226           } elsif (-f MM->catfile($packagedir,"Makefile")) {
3227             $CPAN::Frontend->myprint(qq{
3228 Package comes with a Makefile and without a Makefile.PL.
3229 We\'ll try to build it with that Makefile then.
3230 });
3231             $self->{writemakefile} = "YES";
3232             sleep 2;
3233           } else {
3234             my $fh = FileHandle->new(">$makefilepl")
3235                 or Carp::croak("Could not open >$makefilepl");
3236             my $cf = $self->called_for || "unknown";
3237             $fh->print(
3238 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
3239 # because there was no Makefile.PL supplied.
3240 # Autogenerated on: }.scalar localtime().qq{
3241
3242 use ExtUtils::MakeMaker;
3243 WriteMakefile(NAME => q[$cf]);
3244
3245 });
3246             $CPAN::Frontend->myprint(qq{Package comes without Makefile.PL.
3247   Writing one on our own (calling it $cf)\n});
3248             }
3249         }
3250     }
3251     return $self;
3252 }
3253
3254 sub untar_me {
3255     my($self,$local_file) = @_;
3256     $self->{archived} = "tar";
3257     if (CPAN::Tarzip->untar($local_file)) {
3258         $self->{unwrapped} = "YES";
3259     } else {
3260         $self->{unwrapped} = "NO";
3261     }
3262 }
3263
3264 sub unzip_me {
3265     my($self,$local_file) = @_;
3266     if ($CPAN::META->has_inst("Archive::Zip")) {
3267       $CPAN::Frontend->mywarn("Archive::Zip not yet supported. ".
3268                               "Will use external unzip");
3269     }
3270     my $unzip = $CPAN::Config->{unzip} or
3271         $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
3272     $self->{archived} = "zip";
3273     my @system = ($unzip, $local_file);
3274     if (system(@system) == 0) {
3275         $self->{unwrapped} = "YES";
3276     } else {
3277         $self->{unwrapped} = "NO";
3278     }
3279 }
3280
3281 sub pm2dir_me {
3282     my($self,$local_file) = @_;
3283     $self->{archived} = "pm";
3284     my $to = File::Basename::basename($local_file);
3285     $to =~ s/\.(gz|Z)$//;
3286     if (CPAN::Tarzip->gunzip($local_file,$to)) {
3287         $self->{unwrapped} = "YES";
3288     } else {
3289         $self->{unwrapped} = "NO";
3290     }
3291 }
3292
3293 #-> sub CPAN::Distribution::new ;
3294 sub new {
3295     my($class,%att) = @_;
3296
3297     $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
3298
3299     my $this = { %att };
3300     return bless $this, $class;
3301 }
3302
3303 #-> sub CPAN::Distribution::look ;
3304 sub look {
3305     my($self) = @_;
3306
3307     if ($^O eq 'MacOS') {
3308       $self->ExtUtils::MM_MacOS::look;
3309       return;
3310     }
3311
3312     if (  $CPAN::Config->{'shell'} ) {
3313         $CPAN::Frontend->myprint(qq{
3314 Trying to open a subshell in the build directory...
3315 });
3316     } else {
3317         $CPAN::Frontend->myprint(qq{
3318 Your configuration does not define a value for subshells.
3319 Please define it with "o conf shell <your shell>"
3320 });
3321         return;
3322     }
3323     my $dist = $self->id;
3324     my $dir  = $self->dir or $self->get;
3325     $dir = $self->dir;
3326     my $getcwd;
3327     $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
3328     my $pwd  = CPAN->$getcwd();
3329     chdir($dir);
3330     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
3331     system($CPAN::Config->{'shell'}) == 0
3332         or $CPAN::Frontend->mydie("Subprocess shell error");
3333     chdir($pwd);
3334 }
3335
3336 sub cvs_import {
3337     my($self) = @_;
3338     $self->get;
3339     my $dir = $self->dir;
3340
3341     my $package = $self->called_for;
3342     my $module = $CPAN::META->instance('CPAN::Module', $package);
3343     my $version = $module->cpan_version;
3344
3345     my $userid = $self->{CPAN_USERID};
3346
3347     my $cvs_dir = (split '/', $dir)[-1];
3348     $cvs_dir =~ s/-\d+[^-]+$//;
3349     my $cvs_root =
3350       $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
3351     my $cvs_site_perl =
3352       $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
3353     if ($cvs_site_perl) {
3354         $cvs_dir = "$cvs_site_perl/$cvs_dir";
3355     }
3356     my $cvs_log = qq{"imported $package $version sources"};
3357     $version =~ s/\./_/g;
3358     my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
3359                "$cvs_dir", $userid, "v$version");
3360
3361     my $getcwd;
3362     $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
3363     my $pwd  = CPAN->$getcwd();
3364     chdir($dir);
3365
3366     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
3367
3368     $CPAN::Frontend->myprint(qq{@cmd\n});
3369     system(@cmd) == 0 or
3370         $CPAN::Frontend->mydie("cvs import failed");
3371     chdir($pwd);
3372 }
3373
3374 #-> sub CPAN::Distribution::readme ;
3375 sub readme {
3376     my($self) = @_;
3377     my($dist) = $self->id;
3378     my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
3379     $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
3380     my($local_file);
3381     my($local_wanted) =
3382          MM->catfile(
3383                         $CPAN::Config->{keep_source_where},
3384                         "authors",
3385                         "id",
3386                         split("/","$sans.readme"),
3387                        );
3388     $self->debug("Doing localize") if $CPAN::DEBUG;
3389     $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
3390                                       $local_wanted)
3391         or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
3392
3393     if ($^O eq 'MacOS') {
3394         ExtUtils::MM_MacOS::launch_file($local_file);
3395         return;
3396     }
3397
3398     my $fh_pager = FileHandle->new;
3399     local($SIG{PIPE}) = "IGNORE";
3400     $fh_pager->open("|$CPAN::Config->{'pager'}")
3401         or die "Could not open pager $CPAN::Config->{'pager'}: $!";
3402     my $fh_readme = FileHandle->new;
3403     $fh_readme->open($local_file)
3404         or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
3405     $CPAN::Frontend->myprint(qq{
3406 Displaying file
3407   $local_file
3408 with pager "$CPAN::Config->{'pager'}"
3409 });
3410     sleep 2;
3411     $fh_pager->print(<$fh_readme>);
3412 }
3413
3414 #-> sub CPAN::Distribution::verifyMD5 ;
3415 sub verifyMD5 {
3416     my($self) = @_;
3417   EXCUSE: {
3418         my @e;
3419         $self->{MD5_STATUS} ||= "";
3420         $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
3421         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
3422     }
3423     my($lc_want,$lc_file,@local,$basename);
3424     @local = split("/",$self->{ID});
3425     pop @local;
3426     push @local, "CHECKSUMS";
3427     $lc_want =
3428         MM->catfile($CPAN::Config->{keep_source_where},
3429                       "authors", "id", @local);
3430     local($") = "/";
3431     if (
3432         -s $lc_want
3433         &&
3434         $self->MD5_check_file($lc_want)
3435        ) {
3436         return $self->{MD5_STATUS} = "OK";
3437     }
3438     $lc_file = CPAN::FTP->localize("authors/id/@local",
3439                                    $lc_want,1);
3440     unless ($lc_file) {
3441         $local[-1] .= ".gz";
3442         $lc_file = CPAN::FTP->localize("authors/id/@local",
3443                                        "$lc_want.gz",1);
3444         if ($lc_file) {
3445             $lc_file =~ s/\.gz$//;
3446             CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
3447         } else {
3448             return;
3449         }
3450     }
3451     $self->MD5_check_file($lc_file);
3452 }
3453
3454 #-> sub CPAN::Distribution::MD5_check_file ;
3455 sub MD5_check_file {
3456     my($self,$chk_file) = @_;
3457     my($cksum,$file,$basename);
3458     $file = $self->{localfile};
3459     $basename = File::Basename::basename($file);
3460     my $fh = FileHandle->new;
3461     if (open $fh, $chk_file){
3462         local($/);
3463         my $eval = <$fh>;
3464         $eval =~ s/\015?\012/\n/g;
3465         close $fh;
3466         my($comp) = Safe->new();
3467         $cksum = $comp->reval($eval);
3468         if ($@) {
3469             rename $chk_file, "$chk_file.bad";
3470             Carp::confess($@) if $@;
3471         }
3472     } else {
3473         Carp::carp "Could not open $chk_file for reading";
3474     }
3475
3476     if (exists $cksum->{$basename}{md5}) {
3477         $self->debug("Found checksum for $basename:" .
3478                      "$cksum->{$basename}{md5}\n") if $CPAN::DEBUG;
3479
3480         open($fh, $file);
3481         binmode $fh;
3482         my $eq = $self->eq_MD5($fh,$cksum->{$basename}{'md5'});
3483         $fh->close;
3484         $fh = CPAN::Tarzip->TIEHANDLE($file);
3485
3486         unless ($eq) {
3487           # had to inline it, when I tied it, the tiedness got lost on
3488           # the call to eq_MD5. (Jan 1998)
3489           my $md5 = MD5->new;
3490           my($data,$ref);
3491           $ref = \$data;
3492           while ($fh->READ($ref, 4096) > 0){
3493             $md5->add($data);
3494           }
3495           my $hexdigest = $md5->hexdigest;
3496           $eq += $hexdigest eq $cksum->{$basename}{'md5-ungz'};
3497         }
3498
3499         if ($eq) {
3500           $CPAN::Frontend->myprint("Checksum for $file ok\n");
3501           return $self->{MD5_STATUS} = "OK";
3502         } else {
3503             $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
3504                                      qq{distribution file. }.
3505                                      qq{Please investigate.\n\n}.
3506                                      $self->as_string,
3507                                      $CPAN::META->instance(
3508                                                            'CPAN::Author',
3509                                                            $self->{CPAN_USERID}
3510                                                           )->as_string);
3511
3512             my $wrap = qq{I\'d recommend removing $file. Its MD5
3513 checksum is incorrect. Maybe you have configured your \`urllist\' with
3514 a bad URL. Please check this array with \`o conf urllist\', and
3515 retry.};
3516
3517             $CPAN::Frontend->myprint(Text::Wrap::wrap("","",$wrap));
3518             $CPAN::Frontend->myprint("\n\n");
3519             sleep 3;
3520             return;
3521         }
3522         # close $fh if fileno($fh);
3523     } else {
3524         $self->{MD5_STATUS} ||= "";
3525         if ($self->{MD5_STATUS} eq "NIL") {
3526             $CPAN::Frontend->myprint(qq{
3527 No md5 checksum for $basename in local $chk_file.
3528 Removing $chk_file
3529 });
3530             unlink $chk_file or $CPAN::Frontend->myprint("Could not unlink: $!");
3531             sleep 1;
3532         }
3533         $self->{MD5_STATUS} = "NIL";
3534         return;
3535     }
3536 }
3537
3538 #-> sub CPAN::Distribution::eq_MD5 ;
3539 sub eq_MD5 {
3540     my($self,$fh,$expectMD5) = @_;
3541     my $md5 = MD5->new;
3542     my($data);
3543     while (read($fh, $data, 4096)){
3544       $md5->add($data);
3545     }
3546     # $md5->addfile($fh);
3547     my $hexdigest = $md5->hexdigest;
3548     # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
3549     $hexdigest eq $expectMD5;
3550 }
3551
3552 #-> sub CPAN::Distribution::force ;
3553 sub force {
3554   my($self) = @_;
3555   $self->{'force_update'}++;
3556   for my $att (qw(
3557   MD5_STATUS archived build_dir localfile make install unwrapped
3558   writemakefile
3559  )) {
3560     delete $self->{$att};
3561   }
3562 }
3563
3564 #-> sub CPAN::Distribution::isa_perl ;
3565 sub isa_perl {
3566   my($self) = @_;
3567   my $file = File::Basename::basename($self->id);
3568   return unless $file =~ m{ ^ perl
3569                             -?
3570                             (5)
3571                             ([._-])
3572                             (
3573                              \d{3}(_[0-4][0-9])?
3574                              |
3575                              \d*[24680]\.\d+
3576                             )
3577                             \.tar[._-]gz
3578                             $
3579                           }xs;
3580   "$1.$3";
3581 }
3582
3583 #-> sub CPAN::Distribution::perl ;
3584 sub perl {
3585     my($self) = @_;
3586     my($perl) = MM->file_name_is_absolute($^X) ? $^X : "";
3587     my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
3588     my $pwd  = CPAN->$getcwd();
3589     my $candidate = MM->catfile($pwd,$^X);
3590     $perl ||= $candidate if MM->maybe_command($candidate);
3591     unless ($perl) {
3592         my ($component,$perl_name);
3593       DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
3594             PATH_COMPONENT: foreach $component (MM->path(),
3595                                                 $Config::Config{'binexp'}) {
3596                   next unless defined($component) && $component;
3597                   my($abs) = MM->catfile($component,$perl_name);
3598                   if (MM->maybe_command($abs)) {
3599                       $perl = $abs;
3600                       last DIST_PERLNAME;
3601                   }
3602               }
3603           }
3604     }
3605     $perl;
3606 }
3607
3608 #-> sub CPAN::Distribution::make ;
3609 sub make {
3610     my($self) = @_;
3611     $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id);
3612     # Emergency brake if they said install Pippi and get newest perl
3613     if ($self->isa_perl) {
3614       if (
3615           $self->called_for ne $self->id && ! $self->{'force_update'}
3616          ) {
3617         # if we die here, we break bundles
3618         $CPAN::Frontend->mywarn(sprintf qq{
3619 The most recent version "%s" of the module "%s"
3620 comes with the current version of perl (%s).
3621 I\'ll build that only if you ask for something like
3622     force install %s
3623 or
3624     install %s
3625 },
3626                                $CPAN::META->instance(
3627                                                      'CPAN::Module',
3628                                                      $self->called_for
3629                                                     )->cpan_version,
3630                                $self->called_for,
3631                                $self->isa_perl,
3632                                $self->called_for,
3633                                $self->id);
3634         sleep 5; return;
3635       }
3636     }
3637     $self->get;
3638   EXCUSE: {
3639         my @e;
3640         $self->{archived} eq "NO" and push @e,
3641         "Is neither a tar nor a zip archive.";
3642
3643         $self->{unwrapped} eq "NO" and push @e,
3644         "had problems unarchiving. Please build manually";
3645
3646         exists $self->{writemakefile} &&
3647             $self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e,
3648                 $1 || "Had some problem writing Makefile";
3649
3650         defined $self->{'make'} and push @e,
3651         "Has already been processed within this session";
3652
3653         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
3654     }
3655     $CPAN::Frontend->myprint("\n  CPAN.pm: Going to build ".$self->id."\n\n");
3656     my $builddir = $self->dir;
3657     chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
3658     $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
3659
3660     if ($^O eq 'MacOS') {
3661         ExtUtils::MM_MacOS::make($self);
3662         return;
3663     }
3664
3665     my $system;
3666     if ($self->{'configure'}) {
3667       $system = $self->{'configure'};
3668     } else {
3669         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
3670         my $switch = "";
3671 # This needs a handler that can be turned on or off:
3672 #       $switch = "-MExtUtils::MakeMaker ".
3673 #           "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
3674 #           if $] > 5.00310;
3675         $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
3676     }
3677     unless (exists $self->{writemakefile}) {
3678         local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
3679         my($ret,$pid);
3680         $@ = "";
3681         if ($CPAN::Config->{inactivity_timeout}) {
3682             eval {
3683                 alarm $CPAN::Config->{inactivity_timeout};
3684                 local $SIG{CHLD}; # = sub { wait };
3685                 if (defined($pid = fork)) {
3686                     if ($pid) { #parent
3687                         # wait;
3688                         waitpid $pid, 0;
3689                     } else {    #child
3690                       # note, this exec isn't necessary if
3691                       # inactivity_timeout is 0. On the Mac I'd
3692                       # suggest, we set it always to 0.
3693                       exec $system;
3694                     }
3695                 } else {
3696                     $CPAN::Frontend->myprint("Cannot fork: $!");
3697                     return;
3698                 }
3699             };
3700             alarm 0;
3701             if ($@){
3702                 kill 9, $pid;
3703                 waitpid $pid, 0;
3704                 $CPAN::Frontend->myprint($@);
3705                 $self->{writemakefile} = "NO $@";
3706                 $@ = "";
3707                 return;
3708             }
3709         } else {
3710           $ret = system($system);
3711           if ($ret != 0) {
3712             $self->{writemakefile} = "NO Makefile.PL returned status $ret";
3713             return;
3714           }
3715         }
3716         if (-f "Makefile") {
3717           $self->{writemakefile} = "YES";
3718         } else {
3719           $self->{writemakefile} =
3720               qq{NO Makefile.PL refused to write a Makefile.};
3721           # It's probably worth to record the reason, so let's retry
3722           # local $/;
3723           # my $fh = IO::File->new("$system |"); # STDERR? STDIN?
3724           # $self->{writemakefile} .= <$fh>;
3725         }
3726     }
3727     return if $CPAN::Signal;
3728     if (my @prereq = $self->needs_prereq){
3729       my $id = $self->id;
3730       $CPAN::Frontend->myprint("---- Dependencies detected ".
3731                                "during [$id] -----\n");
3732
3733       for my $p (@prereq) {
3734         $CPAN::Frontend->myprint("    $p\n");
3735       }
3736       my $follow = 0;
3737       if ($CPAN::Config->{prerequisites_policy} eq "follow") {
3738         $follow = 1;
3739       } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
3740         require ExtUtils::MakeMaker;
3741         my $answer = ExtUtils::MakeMaker::prompt(
3742 "Shall I follow them and prepend them to the queue
3743 of modules we are processing right now?", "yes");
3744         $follow = $answer =~ /^\s*y/i;
3745       } else {
3746         local($") = ", ";
3747         $CPAN::Frontend->
3748             myprint("  Ignoring dependencies on modules @prereq\n");
3749       }
3750       if ($follow) {
3751         CPAN::Queue->jumpqueue(@prereq,$id); # requeue yourself
3752         return;
3753       }
3754     }
3755     $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
3756     if (system($system) == 0) {
3757          $CPAN::Frontend->myprint("  $system -- OK\n");
3758          $self->{'make'} = "YES";
3759     } else {
3760          $self->{writemakefile} ||= "YES";
3761          $self->{'make'} = "NO";
3762          $CPAN::Frontend->myprint("  $system -- NOT OK\n");
3763     }
3764 }
3765
3766 #-> sub CPAN::Distribution::needs_prereq ;
3767 sub needs_prereq {
3768   my($self) = @_;
3769   return unless -f "Makefile"; # we cannot say much
3770   my $fh = FileHandle->new("<Makefile") or
3771       $CPAN::Frontend->mydie("Couldn't open Makefile: $!");
3772   local($/) = "\n";
3773
3774   #  A.Speer @p -> %p, where %p is $p{Module::Name}=Required_Version
3775   #
3776   my(%p,@need);
3777   while (<$fh>) {
3778     last if /MakeMaker post_initialize section/;
3779     my($p) = m{^[\#]
3780                  \s+PREREQ_PM\s+=>\s+(.+)
3781                  }x;
3782     next unless $p;
3783     # warn "Found prereq expr[$p]";
3784
3785     #  Regexp modified by A.Speer to remember actual version of file
3786     #  PREREQ_PM hash key wants, then add to
3787     while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
3788       # In case a prereq is mentioned twice, complain.
3789       if ( defined $p{$1} ) {
3790         warn "Warning: PREREQ_PM mentions $1 more than once, last mention wins";
3791       }
3792       $p{$1} = $2;
3793     }
3794     last;
3795   }
3796  NEED: while (my($module, $need_version) = each %p) {
3797     my $mo = $CPAN::META->instance("CPAN::Module",$module);
3798     # we were too demanding:
3799     # next if $mo->uptodate;
3800
3801     # We only want to install prereqs if either they're not installed
3802     # or if the installed version is too old. We cannot omit this
3803     # check, because if 'force' is in effect, nobody else will check.
3804     {
3805       local($^W) = 0;
3806       if (defined $mo->inst_file &&
3807           $mo->inst_version >= $need_version){
3808         CPAN->debug(sprintf "inst_file[%s]inst_version[%s]need_version[%s]",
3809                     $mo->inst_file, $mo->inst_version, $need_version
3810                    );
3811         next NEED;
3812       }
3813     }
3814
3815     if ($self->{have_sponsored}{$module}++){
3816       # We have already sponsored it and for some reason it's still
3817       # not available. So we do nothing. Or what should we do?
3818       # if we push it again, we have a potential infinite loop
3819       next;
3820     }
3821     push @need, $module;
3822   }
3823   return @need;
3824 }
3825
3826 #-> sub CPAN::Distribution::test ;
3827 sub test {
3828     my($self) = @_;
3829     $self->make;
3830     return if $CPAN::Signal;
3831     $CPAN::Frontend->myprint("Running make test\n");
3832   EXCUSE: {
3833         my @e;
3834         exists $self->{'make'} or push @e,
3835         "Make had some problems, maybe interrupted? Won't test";
3836
3837         exists $self->{'make'} and
3838             $self->{'make'} eq 'NO' and
3839                 push @e, "Oops, make had returned bad status";
3840
3841         exists $self->{'build_dir'} or push @e, "Has no own directory";
3842         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
3843     }
3844     chdir $self->{'build_dir'} or
3845         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
3846     $self->debug("Changed directory to $self->{'build_dir'}")
3847         if $CPAN::DEBUG;
3848
3849     if ($^O eq 'MacOS') {
3850         ExtUtils::MM_MacOS::make_test($self);
3851         return;
3852     }
3853
3854     my $system = join " ", $CPAN::Config->{'make'}, "test";
3855     if (system($system) == 0) {
3856          $CPAN::Frontend->myprint("  $system -- OK\n");
3857          $self->{'make_test'} = "YES";
3858     } else {
3859          $self->{'make_test'} = "NO";
3860          $CPAN::Frontend->myprint("  $system -- NOT OK\n");
3861     }
3862 }
3863
3864 #-> sub CPAN::Distribution::clean ;
3865 sub clean {
3866     my($self) = @_;
3867     $CPAN::Frontend->myprint("Running make clean\n");
3868   EXCUSE: {
3869         my @e;
3870         exists $self->{'build_dir'} or push @e, "Has no own directory";
3871         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
3872     }
3873     chdir $self->{'build_dir'} or
3874         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
3875     $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
3876
3877     if ($^O eq 'MacOS') {
3878         ExtUtils::MM_MacOS::make_clean($self);
3879         return;
3880     }
3881
3882     my $system = join " ", $CPAN::Config->{'make'}, "clean";
3883     if (system($system) == 0) {
3884         $CPAN::Frontend->myprint("  $system -- OK\n");
3885         $self->force;
3886     } else {
3887         # Hmmm, what to do if make clean failed?
3888     }
3889 }
3890
3891 #-> sub CPAN::Distribution::install ;
3892 sub install {
3893     my($self) = @_;
3894     $self->test;
3895     return if $CPAN::Signal;
3896     $CPAN::Frontend->myprint("Running make install\n");
3897   EXCUSE: {
3898         my @e;
3899         exists $self->{'build_dir'} or push @e, "Has no own directory";
3900
3901         exists $self->{'make'} or push @e,
3902         "Make had some problems, maybe interrupted? Won't install";
3903
3904         exists $self->{'make'} and
3905             $self->{'make'} eq 'NO' and
3906                 push @e, "Oops, make had returned bad status";
3907
3908         push @e, "make test had returned bad status, ".
3909             "won't install without force"
3910             if exists $self->{'make_test'} and
3911             $self->{'make_test'} eq 'NO' and
3912             ! $self->{'force_update'};
3913
3914         exists $self->{'install'} and push @e,
3915         $self->{'install'} eq "YES" ?
3916             "Already done" : "Already tried without success";
3917
3918         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
3919     }
3920     chdir $self->{'build_dir'} or
3921         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
3922     $self->debug("Changed directory to $self->{'build_dir'}")
3923         if $CPAN::DEBUG;
3924
3925     if ($^O eq 'MacOS') {
3926         ExtUtils::MM_MacOS::make_install($self);
3927         return;
3928     }
3929
3930     my $system = join(" ", $CPAN::Config->{'make'},
3931                       "install", $CPAN::Config->{make_install_arg});
3932     my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 ";
3933     my($pipe) = FileHandle->new("$system $stderr |");
3934     my($makeout) = "";
3935     while (<$pipe>){
3936         $CPAN::Frontend->myprint($_);
3937         $makeout .= $_;
3938     }
3939     $pipe->close;
3940     if ($?==0) {
3941          $CPAN::Frontend->myprint("  $system -- OK\n");
3942          return $self->{'install'} = "YES";
3943     } else {
3944          $self->{'install'} = "NO";
3945          $CPAN::Frontend->myprint("  $system -- NOT OK\n");
3946          if ($makeout =~ /permission/s && $> > 0) {
3947              $CPAN::Frontend->myprint(qq{    You may have to su }.
3948                                       qq{to root to install the package\n});
3949          }
3950     }
3951 }
3952
3953 #-> sub CPAN::Distribution::dir ;
3954 sub dir {
3955     shift->{'build_dir'};
3956 }
3957
3958 package CPAN::Bundle;
3959
3960 #-> sub CPAN::Bundle::as_string ;
3961 sub as_string {
3962     my($self) = @_;
3963     $self->contains;
3964     $self->{INST_VERSION} = $self->inst_version;
3965     return $self->SUPER::as_string;
3966 }
3967
3968 #-> sub CPAN::Bundle::contains ;
3969 sub contains {
3970   my($self) = @_;
3971   my($parsefile) = $self->inst_file;
3972   my($id) = $self->id;
3973   $self->debug("parsefile[$parsefile]id[$id]") if $CPAN::DEBUG;
3974   unless ($parsefile) {
3975     # Try to get at it in the cpan directory
3976     $self->debug("no parsefile") if $CPAN::DEBUG;
3977     Carp::confess "I don't know a $id" unless $self->{CPAN_FILE};
3978     my $dist = $CPAN::META->instance('CPAN::Distribution',
3979                                      $self->{CPAN_FILE});
3980     $dist->get;
3981     $self->debug($dist->as_string) if $CPAN::DEBUG;
3982     my($todir) = $CPAN::Config->{'cpan_home'};
3983     my(@me,$from,$to,$me);
3984     @me = split /::/, $self->id;
3985     $me[-1] .= ".pm";
3986     $me = MM->catfile(@me);
3987     $from = $self->find_bundle_file($dist->{'build_dir'},$me);
3988     $to = MM->catfile($todir,$me);
3989     File::Path::mkpath(File::Basename::dirname($to));
3990     File::Copy::copy($from, $to)
3991         or Carp::confess("Couldn't copy $from to $to: $!");
3992     $parsefile = $to;
3993   }
3994   my @result;
3995   my $fh = FileHandle->new;
3996   local $/ = "\n";
3997   open($fh,$parsefile) or die "Could not open '$parsefile': $!";
3998   my $in_cont = 0;
3999   $self->debug("parsefile[$parsefile]") if $CPAN::DEBUG;
4000   while (<$fh>) {
4001     $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
4002         m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
4003     next unless $in_cont;
4004     next if /^=/;
4005     s/\#.*//;
4006     next if /^\s+$/;
4007     chomp;
4008     push @result, (split " ", $_, 2)[0];
4009   }
4010   close $fh;
4011   delete $self->{STATUS};
4012   $self->{CONTAINS} = join ", ", @result;
4013   $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
4014   unless (@result) {
4015     $CPAN::Frontend->mywarn(qq{
4016 The bundle file "$parsefile" may be a broken
4017 bundlefile. It seems not to contain any bundle definition.
4018 Please check the file and if it is bogus, please delete it.
4019 Sorry for the inconvenience.
4020 });
4021   }
4022   @result;
4023 }
4024
4025 #-> sub CPAN::Bundle::find_bundle_file
4026 sub find_bundle_file {
4027     my($self,$where,$what) = @_;
4028     $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
4029 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
4030 ###    my $bu = MM->catfile($where,$what);
4031 ###    return $bu if -f $bu;
4032     my $manifest = MM->catfile($where,"MANIFEST");
4033     unless (-f $manifest) {
4034         require ExtUtils::Manifest;
4035         my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
4036         my $cwd = CPAN->$getcwd();
4037         chdir $where;
4038         ExtUtils::Manifest::mkmanifest();
4039         chdir $cwd;
4040     }
4041     my $fh = FileHandle->new($manifest)
4042         or Carp::croak("Couldn't open $manifest: $!");
4043     local($/) = "\n";
4044     my $what2 = $what;
4045     if ($^O eq 'MacOS') {
4046       $what =~ s/^://;
4047       $what2 =~ tr|:|/|;
4048       $what2 =~ s/:Bundle://;
4049       $what2 =~ tr|:|/|;
4050     } else {
4051         $what2 =~ s|Bundle[/\\]||;
4052     }
4053     my $bu;
4054     while (<$fh>) {
4055         next if /^\s*\#/;
4056         my($file) = /(\S+)/;
4057         if ($file =~ m|\Q$what\E$|) {
4058             $bu = $file;
4059             # return MM->catfile($where,$bu); # bad
4060             last;
4061         }
4062         # retry if she managed to
4063         # have no Bundle directory
4064         $bu = $file if $file =~ m|\Q$what2\E$|;
4065     }
4066     $bu =~ tr|/|:| if $^O eq 'MacOS';
4067     return MM->catfile($where, $bu) if $bu;
4068     Carp::croak("Couldn't find a Bundle file in $where");
4069 }
4070
4071 #-> sub CPAN::Bundle::inst_file ;
4072 sub inst_file {
4073     my($self) = @_;
4074     my($me,$inst_file);
4075     ($me = $self->id) =~ s/.*://;
4076 ##    my(@me,$inst_file);
4077 ##    @me = split /::/, $self->id;
4078 ##    $me[-1] .= ".pm";
4079     $inst_file = MM->catfile($CPAN::Config->{'cpan_home'},
4080                                       "Bundle", "$me.pm");
4081 ##                                    "Bundle", @me);
4082     return $self->{'INST_FILE'} = $inst_file if -f $inst_file;
4083 #    $inst_file =
4084     $self->SUPER::inst_file;
4085 #    return $self->{'INST_FILE'} = $inst_file if -f $inst_file;
4086 #    return $self->{'INST_FILE'}; # even if undefined?
4087 }
4088
4089 #-> sub CPAN::Bundle::rematein ;
4090 sub rematein {
4091     my($self,$meth) = @_;
4092     $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
4093     my($id) = $self->id;
4094     Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
4095         unless $self->inst_file || $self->{CPAN_FILE};
4096     my($s,%fail);
4097     for $s ($self->contains) {
4098         my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
4099             $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
4100         if ($type eq 'CPAN::Distribution') {
4101             $CPAN::Frontend->mywarn(qq{
4102 The Bundle }.$self->id.qq{ contains
4103 explicitly a file $s.
4104 });
4105             sleep 3;
4106         }
4107         # possibly noisy action:
4108         $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
4109         my $obj = $CPAN::META->instance($type,$s);
4110         $obj->$meth();
4111         if ($obj->isa(CPAN::Bundle)
4112             &&
4113             exists $obj->{install_failed}
4114             &&
4115             ref($obj->{install_failed}) eq "HASH"
4116            ) {
4117           for (keys %{$obj->{install_failed}}) {
4118             $self->{install_failed}{$_} = undef; # propagate faiure up
4119                                                  # to me in a
4120                                                  # recursive call
4121             $fail{$s} = 1; # the bundle itself may have succeeded but
4122                            # not all children
4123           }
4124         } else {
4125           my $success;
4126           $success = $obj->can("uptodate") ? $obj->uptodate : 0;
4127           $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
4128           if ($success) {
4129             delete $self->{install_failed}{$s};
4130           } else {
4131             $fail{$s} = 1;
4132           }
4133         }
4134     }
4135
4136     # recap with less noise
4137     if ( $meth eq "install" ) {
4138         if (%fail) {
4139             require Text::Wrap;
4140             my $raw = sprintf(qq{Bundle summary:
4141 The following items in bundle %s had installation problems:},
4142                               $self->id
4143                              );
4144             $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
4145             $CPAN::Frontend->myprint("\n");
4146             my $paragraph = "";
4147             my %reported;
4148             for $s ($self->contains) {
4149               if ($fail{$s}){
4150                 $paragraph .= "$s ";
4151                 $self->{install_failed}{$s} = undef;
4152                 $reported{$s} = undef;
4153               }
4154             }
4155             my $report_propagated;
4156             for $s (sort keys %{$self->{install_failed}}) {
4157               next if exists $reported{$s};
4158               $paragraph .= "and the following items had problems
4159 during recursive bundle calls: " unless $report_propagated++;
4160               $paragraph .= "$s ";
4161             }
4162             $CPAN::Frontend->myprint(Text::Wrap::fill("  ","  ",$paragraph));
4163             $CPAN::Frontend->myprint("\n");
4164         } else {
4165             $self->{'install'} = 'YES';
4166         }
4167     }
4168 }
4169
4170 #sub CPAN::Bundle::xs_file
4171 sub xs_file {
4172     # If a bundle contains another that contains an xs_file we have
4173     # here, we just don't bother I suppose
4174     return 0;
4175 }
4176
4177 #-> sub CPAN::Bundle::force ;
4178 sub force   { shift->rematein('force',@_); }
4179 #-> sub CPAN::Bundle::get ;
4180 sub get     { shift->rematein('get',@_); }
4181 #-> sub CPAN::Bundle::make ;
4182 sub make    { shift->rematein('make',@_); }
4183 #-> sub CPAN::Bundle::test ;
4184 sub test    { shift->rematein('test',@_); }
4185 #-> sub CPAN::Bundle::install ;
4186 sub install {
4187   my $self = shift;
4188   $self->rematein('install',@_);
4189 }
4190 #-> sub CPAN::Bundle::clean ;
4191 sub clean   { shift->rematein('clean',@_); }
4192
4193 #-> sub CPAN::Bundle::readme ;
4194 sub readme  {
4195     my($self) = @_;
4196     my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
4197 No File found for bundle } . $self->id . qq{\n}), return;
4198     $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
4199     $CPAN::META->instance('CPAN::Distribution',$file)->readme;
4200 }
4201
4202 package CPAN::Module;
4203
4204 #-> sub CPAN::Module::as_glimpse ;
4205 sub as_glimpse {
4206     my($self) = @_;
4207     my(@m);
4208     my $class = ref($self);
4209     $class =~ s/^CPAN:://;
4210     push @m, sprintf("%-15s %-15s (%s)\n", $class, $self->{ID},
4211                      $self->cpan_file);
4212     join "", @m;
4213 }
4214
4215 #-> sub CPAN::Module::as_string ;
4216 sub as_string {
4217     my($self) = @_;
4218     my(@m);
4219     CPAN->debug($self) if $CPAN::DEBUG;
4220     my $class = ref($self);
4221     $class =~ s/^CPAN:://;
4222     local($^W) = 0;
4223     push @m, $class, " id = $self->{ID}\n";
4224     my $sprintf = "    %-12s %s\n";
4225     push @m, sprintf($sprintf, 'DESCRIPTION', $self->{description})
4226         if $self->{description};
4227     my $sprintf2 = "    %-12s %s (%s)\n";
4228     my($userid);
4229     if ($userid = $self->{'CPAN_USERID'} || $self->{'userid'}){
4230         my $author;
4231         if ($author = CPAN::Shell->expand('Author',$userid)) {
4232           my $email = "";
4233           my $m; # old perls
4234           if ($m = $author->email) {
4235             $email = " <$m>";
4236           }
4237           push @m, sprintf(
4238                            $sprintf2,
4239                            'CPAN_USERID',
4240                            $userid,
4241                            $author->fullname . $email
4242                           );
4243         }
4244     }
4245     push @m, sprintf($sprintf, 'CPAN_VERSION', $self->{CPAN_VERSION})
4246         if $self->{CPAN_VERSION};
4247     push @m, sprintf($sprintf, 'CPAN_FILE', $self->{CPAN_FILE})
4248         if $self->{CPAN_FILE};
4249     my $sprintf3 = "    %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
4250     my(%statd,%stats,%statl,%stati);
4251     @statd{qw,? i c a b R M S,} = qw,unknown idea
4252         pre-alpha alpha beta released mature standard,;
4253     @stats{qw,? m d u n,}       = qw,unknown mailing-list
4254         developer comp.lang.perl.* none,;
4255     @statl{qw,? p c + o h,}       = qw,unknown perl C C++ other hybrid,;
4256     @stati{qw,? f r O h,}         = qw,unknown functions
4257         references+ties object-oriented hybrid,;
4258     $statd{' '} = 'unknown';
4259     $stats{' '} = 'unknown';
4260     $statl{' '} = 'unknown';
4261     $stati{' '} = 'unknown';
4262     push @m, sprintf(
4263                      $sprintf3,
4264                      'DSLI_STATUS',
4265                      $self->{statd},
4266                      $self->{stats},
4267                      $self->{statl},
4268                      $self->{stati},
4269                      $statd{$self->{statd}},
4270                      $stats{$self->{stats}},
4271                      $statl{$self->{statl}},
4272                      $stati{$self->{stati}}
4273                     ) if $self->{statd};
4274     my $local_file = $self->inst_file;
4275     if ($local_file) {
4276       $self->{MANPAGE} ||= $self->manpage_headline($local_file);
4277     }
4278     my($item);
4279     for $item (qw/MANPAGE CONTAINS/) {
4280         push @m, sprintf($sprintf, $item, $self->{$item})
4281             if exists $self->{$item};
4282     }
4283     push @m, sprintf($sprintf, 'INST_FILE',
4284                      $local_file || "(not installed)");
4285     push @m, sprintf($sprintf, 'INST_VERSION',
4286                      $self->inst_version) if $local_file;
4287     join "", @m, "\n";
4288 }
4289
4290 sub manpage_headline {
4291   my($self,$local_file) = @_;
4292   my(@local_file) = $local_file;
4293   $local_file =~ s/\.pm$/.pod/;
4294   push @local_file, $local_file;
4295   my(@result,$locf);
4296   for $locf (@local_file) {
4297     next unless -f $locf;
4298     my $fh = FileHandle->new($locf)
4299         or $Carp::Frontend->mydie("Couldn't open $locf: $!");
4300     my $inpod = 0;
4301     local $/ = "\n";
4302     while (<$fh>) {
4303       $inpod = m/^=(?!head1\s+NAME)/ ? 0 :
4304           m/^=head1\s+NAME/ ? 1 : $inpod;
4305       next unless $inpod;
4306       next if /^=/;
4307       next if /^\s+$/;
4308       chomp;
4309       push @result, $_;
4310     }
4311     close $fh;
4312     last if @result;
4313   }
4314   join " ", @result;
4315 }
4316
4317 #-> sub CPAN::Module::cpan_file ;
4318 sub cpan_file    {
4319     my $self = shift;
4320     CPAN->debug($self->id) if $CPAN::DEBUG;
4321     unless (defined $self->{'CPAN_FILE'}) {
4322         CPAN::Index->reload;
4323     }
4324     if (exists $self->{'CPAN_FILE'} && defined $self->{'CPAN_FILE'}){
4325         return $self->{'CPAN_FILE'};
4326     } elsif (exists $self->{'userid'} && defined $self->{'userid'}) {
4327         my $fullname = $CPAN::META->instance(CPAN::Author,
4328                                       $self->{'userid'})->fullname;
4329         my $email = $CPAN::META->instance(CPAN::Author,
4330                                       $self->{'userid'})->email;
4331         unless (defined $fullname && defined $email) {
4332             return "Contact Author $self->{userid} (Try ``a $self->{userid}'')";
4333         }
4334         return "Contact Author $fullname <$email>";
4335     } else {
4336         return "N/A";
4337     }
4338 }
4339
4340 *name = \&cpan_file;
4341
4342 #-> sub CPAN::Module::cpan_version ;
4343 sub cpan_version {
4344     my $self = shift;
4345     $self->{'CPAN_VERSION'} = 'undef'
4346         unless defined $self->{'CPAN_VERSION'}; # I believe this is
4347                                                 # always a bug in the
4348                                                 # index and should be
4349                                                 # reported as such,
4350                                                 # but usually I find
4351                                                 # out such an error
4352                                                 # and do not want to
4353                                                 # provoke too many
4354                                                 # bugreports
4355     $self->{'CPAN_VERSION'};
4356 }
4357
4358 #-> sub CPAN::Module::force ;
4359 sub force {
4360     my($self) = @_;
4361     $self->{'force_update'}++;
4362 }
4363
4364 #-> sub CPAN::Module::rematein ;
4365 sub rematein {
4366     my($self,$meth) = @_;
4367     $self->debug($self->id) if $CPAN::DEBUG;
4368     my $cpan_file = $self->cpan_file;
4369     if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
4370       $CPAN::Frontend->mywarn(sprintf qq{
4371   The module %s isn\'t available on CPAN.
4372
4373   Either the module has not yet been uploaded to CPAN, or it is
4374   temporary unavailable. Please contact the author to find out
4375   more about the status. Try ``i %s''.
4376 },
4377                               $self->id,
4378                               $self->id,
4379                              );
4380       return;
4381     }
4382     my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
4383     $pack->called_for($self->id);
4384     $pack->force if exists $self->{'force_update'};
4385     $pack->$meth();
4386     delete $self->{'force_update'};
4387 }
4388
4389 #-> sub CPAN::Module::readme ;
4390 sub readme { shift->rematein('readme') }
4391 #-> sub CPAN::Module::look ;
4392 sub look { shift->rematein('look') }
4393 #-> sub CPAN::Module::cvs_import ;
4394 sub cvs_import { shift->rematein('cvs_import') }
4395 #-> sub CPAN::Module::get ;
4396 sub get    { shift->rematein('get',@_); }
4397 #-> sub CPAN::Module::make ;
4398 sub make   { shift->rematein('make') }
4399 #-> sub CPAN::Module::test ;
4400 sub test   { shift->rematein('test') }
4401 #-> sub CPAN::Module::uptodate ;
4402 sub uptodate {
4403     my($self) = @_;
4404     my($latest) = $self->cpan_version;
4405     $latest ||= 0;
4406     my($inst_file) = $self->inst_file;
4407     my($have) = 0;
4408     if (defined $inst_file) {
4409         $have = $self->inst_version;
4410     }
4411     local($^W)=0;
4412     if ($inst_file
4413         &&
4414         $have >= $latest
4415        ) {
4416       return 1;
4417     }
4418     return;
4419 }
4420 #-> sub CPAN::Module::install ;
4421 sub install {
4422     my($self) = @_;
4423     my($doit) = 0;
4424     if ($self->uptodate
4425         &&
4426         not exists $self->{'force_update'}
4427        ) {
4428         $CPAN::Frontend->myprint( $self->id. " is up to date.\n");
4429     } else {
4430         $doit = 1;
4431     }
4432     $self->rematein('install') if $doit;
4433 }
4434 #-> sub CPAN::Module::clean ;
4435 sub clean  { shift->rematein('clean') }
4436
4437 #-> sub CPAN::Module::inst_file ;
4438 sub inst_file {
4439     my($self) = @_;
4440     my($dir,@packpath);
4441     @packpath = split /::/, $self->{ID};
4442     $packpath[-1] .= ".pm";
4443     foreach $dir (@INC) {
4444         my $pmfile = MM->catfile($dir,@packpath);
4445         if (-f $pmfile){
4446             return $pmfile;
4447         }
4448     }
4449     return;
4450 }
4451
4452 #-> sub CPAN::Module::xs_file ;
4453 sub xs_file {
4454     my($self) = @_;
4455     my($dir,@packpath);
4456     @packpath = split /::/, $self->{ID};
4457     push @packpath, $packpath[-1];
4458     $packpath[-1] .= "." . $Config::Config{'dlext'};
4459     foreach $dir (@INC) {
4460         my $xsfile = MM->catfile($dir,'auto',@packpath);
4461         if (-f $xsfile){
4462             return $xsfile;
4463         }
4464     }
4465     return;
4466 }
4467
4468 #-> sub CPAN::Module::inst_version ;
4469 sub inst_version {
4470     my($self) = @_;
4471     my $parsefile = $self->inst_file or return;
4472     local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
4473     # warn "HERE";
4474     my $have;
4475     # local($SIG{__WARN__}) =  sub { warn "1. have[$have]"; };
4476
4477     # there was a bug in 5.6.0 that let lots of unini warnings out of
4478     # parse_version. Fixed shortly after 5.6.0 by PMQS. We can remove
4479     # this workaround after 5.6.1 is out.
4480     local($SIG{__WARN__}) =  sub { my $w = shift;
4481                                    return if $w =~ /uninitialized/i;
4482                                    warn $w;
4483                                  };
4484     $have = MM->parse_version($parsefile) || "undef";
4485     # local($SIG{__WARN__}) =  sub { warn "2. have[$have]"; };
4486     $have =~ s/\s*//g; # stringify to float around floating point issues
4487     # local($SIG{__WARN__}) =  sub { warn "3. have[$have]"; };
4488     $have; # no stringify needed, \s* above matches always
4489 }
4490
4491 package CPAN::Tarzip;
4492
4493 # CPAN::Tarzip::gzip
4494 sub gzip {
4495   my($class,$read,$write) = @_;
4496   if ($CPAN::META->has_inst("Compress::Zlib")) {
4497     my($buffer,$fhw);
4498     $fhw = FileHandle->new($read)
4499         or $CPAN::Frontend->mydie("Could not open $read: $!");
4500     my $gz = Compress::Zlib::gzopen($write, "wb")
4501         or $CPAN::Frontend->mydie("Cannot gzopen $write: $!\n");
4502     $gz->gzwrite($buffer)
4503         while read($fhw,$buffer,4096) > 0 ;
4504     $gz->gzclose() ;
4505     $fhw->close;
4506     return 1;
4507   } else {
4508     system("$CPAN::Config->{'gzip'} -c $read > $write")==0;
4509   }
4510 }
4511
4512
4513 # CPAN::Tarzip::gunzip
4514 sub gunzip {
4515   my($class,$read,$write) = @_;
4516   if ($CPAN::META->has_inst("Compress::Zlib")) {
4517     my($buffer,$fhw);
4518     $fhw = FileHandle->new(">$write")
4519         or $CPAN::Frontend->mydie("Could not open >$write: $!");
4520     my $gz = Compress::Zlib::gzopen($read, "rb")
4521         or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
4522     $fhw->print($buffer)
4523         while $gz->gzread($buffer) > 0 ;
4524     $CPAN::Frontend->mydie("Error reading from $read: $!\n")
4525         if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
4526     $gz->gzclose() ;
4527     $fhw->close;
4528     return 1;
4529   } else {
4530     system("$CPAN::Config->{'gzip'} -dc $read > $write")==0;
4531   }
4532 }
4533
4534
4535 # CPAN::Tarzip::gtest
4536 sub gtest {
4537   my($class,$read) = @_;
4538   if ($CPAN::META->has_inst("Compress::Zlib")) {
4539     my($buffer);
4540     my $gz = Compress::Zlib::gzopen($read, "rb")
4541         or $CPAN::Frontend->mydie("Cannot open $read: $!\n");
4542     1 while $gz->gzread($buffer) > 0 ;
4543     my $err = $gz->gzerror;
4544     my $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
4545     $gz->gzclose();
4546     $class->debug("err[$err]success[$success]") if $CPAN::DEBUG;
4547     return $success;
4548   } else {
4549     return system("$CPAN::Config->{'gzip'} -dt $read")==0;
4550   }
4551 }
4552
4553
4554 # CPAN::Tarzip::TIEHANDLE
4555 sub TIEHANDLE {
4556   my($class,$file) = @_;
4557   my $ret;
4558   $class->debug("file[$file]");
4559   if ($CPAN::META->has_inst("Compress::Zlib")) {
4560     my $gz = Compress::Zlib::gzopen($file,"rb") or
4561         die "Could not gzopen $file";
4562     $ret = bless {GZ => $gz}, $class;
4563   } else {
4564     my $pipe = "$CPAN::Config->{'gzip'} --decompress --stdout $file |";
4565     my $fh = FileHandle->new($pipe) or die "Could pipe[$pipe]: $!";
4566     binmode $fh;
4567     $ret = bless {FH => $fh}, $class;
4568   }
4569   $ret;
4570 }
4571
4572
4573 # CPAN::Tarzip::READLINE
4574 sub READLINE {
4575   my($self) = @_;
4576   if (exists $self->{GZ}) {
4577     my $gz = $self->{GZ};
4578     my($line,$bytesread);
4579     $bytesread = $gz->gzreadline($line);
4580     return undef if $bytesread <= 0;
4581     return $line;
4582   } else {
4583     my $fh = $self->{FH};
4584     return scalar <$fh>;
4585   }
4586 }
4587
4588
4589 # CPAN::Tarzip::READ
4590 sub READ {
4591   my($self,$ref,$length,$offset) = @_;
4592   die "read with offset not implemented" if defined $offset;
4593   if (exists $self->{GZ}) {
4594     my $gz = $self->{GZ};
4595     my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
4596     return $byteread;
4597   } else {
4598     my $fh = $self->{FH};
4599     return read($fh,$$ref,$length);
4600   }
4601 }
4602
4603
4604 # CPAN::Tarzip::DESTROY
4605 sub DESTROY {
4606   my($self) = @_;
4607   if (exists $self->{GZ}) {
4608     my $gz = $self->{GZ};
4609     $gz->gzclose();
4610   } else {
4611     my $fh = $self->{FH};
4612     $fh->close if defined $fh;
4613   }
4614   undef $self;
4615 }
4616
4617
4618 # CPAN::Tarzip::untar
4619 sub untar {
4620   my($class,$file) = @_;
4621   # had to disable, because version 0.07 seems to be buggy
4622   if (MM->maybe_command($CPAN::Config->{'gzip'})
4623       &&
4624       MM->maybe_command($CPAN::Config->{'tar'})) {
4625     my $system = "$CPAN::Config->{'gzip'} --decompress --stdout " .
4626       "< $file | $CPAN::Config->{tar} xvf -";
4627     if (system($system) != 0) {
4628       # people find the most curious tar binaries that cannot handle
4629       # pipes
4630       my $system = "$CPAN::Config->{'gzip'} --decompress $file";
4631       if (system($system)==0) {
4632         $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
4633       } else {
4634         $CPAN::Frontend->mydie(
4635                                qq{Couldn\'t uncompress $file\n}
4636                               );
4637       }
4638       $file =~ s/\.gz$//;
4639       $system = "$CPAN::Config->{tar} xvf $file";
4640       $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
4641       if (system($system)==0) {
4642         $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
4643       } else {
4644         $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
4645       }
4646       return 1;
4647     } else {
4648       return 1;
4649     }
4650   } elsif ($CPAN::META->has_inst("Archive::Tar")
4651       &&
4652       $CPAN::META->has_inst("Compress::Zlib") ) {
4653     my $tar = Archive::Tar->new($file,1);
4654     $tar->extract($tar->list_files); # I'm pretty sure we have nothing
4655                                      # that isn't compressed
4656
4657     ExtUtils::MM_MacOS::convert_files([$tar->list_files], 1)
4658         if ($^O eq 'MacOS');
4659
4660     return 1;
4661   } else {
4662     $CPAN::Frontend->mydie(qq{
4663 CPAN.pm needs either both external programs tar and gzip installed or
4664 both the modules Archive::Tar and Compress::Zlib. Neither prerequisite
4665 is available. Can\'t continue.
4666 });
4667   }
4668 }
4669
4670 package CPAN;
4671
4672 1;
4673
4674 __END__
4675
4676 =head1 NAME
4677
4678 CPAN - query, download and build perl modules from CPAN sites
4679
4680 =head1 SYNOPSIS
4681
4682 Interactive mode:
4683
4684   perl -MCPAN -e shell;
4685
4686 Batch mode:
4687
4688   use CPAN;
4689
4690   autobundle, clean, install, make, recompile, test
4691
4692 =head1 DESCRIPTION
4693
4694 The CPAN module is designed to automate the make and install of perl
4695 modules and extensions. It includes some searching capabilities and
4696 knows how to use Net::FTP or LWP (or lynx or an external ftp client)
4697 to fetch the raw data from the net.
4698
4699 Modules are fetched from one or more of the mirrored CPAN
4700 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
4701 directory.
4702
4703 The CPAN module also supports the concept of named and versioned
4704 I<bundles> of modules. Bundles simplify the handling of sets of
4705 related modules. See Bundles below.
4706
4707 The package contains a session manager and a cache manager. There is
4708 no status retained between sessions. The session manager keeps track
4709 of what has been fetched, built and installed in the current
4710 session. The cache manager keeps track of the disk space occupied by
4711 the make processes and deletes excess space according to a simple FIFO
4712 mechanism.
4713
4714 For extended searching capabilities there's a plugin for CPAN available,
4715 L<CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine that indexes
4716 all documents available in CPAN authors directories. If C<CPAN::WAIT>
4717 is installed on your system, the interactive shell of <CPAN.pm> will
4718 enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands which send
4719 queries to the WAIT server that has been configured for your
4720 installation.
4721
4722 All other methods provided are accessible in a programmer style and in an
4723 interactive shell style.
4724
4725 =head2 Interactive Mode
4726
4727 The interactive mode is entered by running
4728
4729     perl -MCPAN -e shell
4730
4731 which puts you into a readline interface. You will have the most fun if
4732 you install Term::ReadKey and Term::ReadLine to enjoy both history and
4733 command completion.
4734
4735 Once you are on the command line, type 'h' and the rest should be
4736 self-explanatory.
4737
4738 The most common uses of the interactive modes are
4739
4740 =over 2
4741
4742 =item Searching for authors, bundles, distribution files and modules
4743
4744 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
4745 for each of the four categories and another, C<i> for any of the
4746 mentioned four. Each of the four entities is implemented as a class
4747 with slightly differing methods for displaying an object.
4748
4749 Arguments you pass to these commands are either strings exactly matching
4750 the identification string of an object or regular expressions that are
4751 then matched case-insensitively against various attributes of the
4752 objects. The parser recognizes a regular expression only if you
4753 enclose it between two slashes.
4754
4755 The principle is that the number of found objects influences how an
4756 item is displayed. If the search finds one item, the result is
4757 displayed with the rather verbose method C<as_string>, but if we find
4758 more than one, we display each object with the terse method
4759 <as_glimpse>.
4760
4761 =item make, test, install, clean  modules or distributions
4762
4763 These commands take any number of arguments and investigate what is
4764 necessary to perform the action. If the argument is a distribution
4765 file name (recognized by embedded slashes), it is processed. If it is
4766 a module, CPAN determines the distribution file in which this module
4767 is included and processes that, following any dependencies named in
4768 the module's Makefile.PL (this behavior is controlled by
4769 I<prerequisites_policy>.)
4770
4771 Any C<make> or C<test> are run unconditionally. An
4772
4773   install <distribution_file>
4774
4775 also is run unconditionally. But for
4776
4777   install <module>
4778
4779 CPAN checks if an install is actually needed for it and prints
4780 I<module up to date> in the case that the distribution file containing
4781 the module doesn't need to be updated.
4782
4783 CPAN also keeps track of what it has done within the current session
4784 and doesn't try to build a package a second time regardless if it
4785 succeeded or not. The C<force> command takes as a first argument the
4786 method to invoke (currently: C<make>, C<test>, or C<install>) and executes the
4787 command from scratch.
4788
4789 Example:
4790
4791     cpan> install OpenGL
4792     OpenGL is up to date.
4793     cpan> force install OpenGL
4794     Running make
4795     OpenGL-0.4/
4796     OpenGL-0.4/COPYRIGHT
4797     [...]
4798
4799 A C<clean> command results in a
4800
4801   make clean
4802
4803 being executed within the distribution file's working directory.
4804
4805 =item get, readme, look module or distribution
4806
4807 C<get> downloads a distribution file without further action. C<readme>
4808 displays the README file of the associated distribution. C<Look> gets
4809 and untars (if not yet done) the distribution file, changes to the
4810 appropriate directory and opens a subshell process in that directory.
4811
4812 =item Signals
4813
4814 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
4815 in the cpan-shell it is intended that you can press C<^C> anytime and
4816 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
4817 to clean up and leave the shell loop. You can emulate the effect of a
4818 SIGTERM by sending two consecutive SIGINTs, which usually means by
4819 pressing C<^C> twice.
4820
4821 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
4822 SIGALRM is used during the run of the C<perl Makefile.PL> subprocess.
4823
4824 =back
4825
4826 =head2 CPAN::Shell
4827
4828 The commands that are available in the shell interface are methods in
4829 the package CPAN::Shell. If you enter the shell command, all your
4830 input is split by the Text::ParseWords::shellwords() routine which
4831 acts like most shells do. The first word is being interpreted as the
4832 method to be called and the rest of the words are treated as arguments
4833 to this method. Continuation lines are supported if a line ends with a
4834 literal backslash.
4835
4836 =head2 autobundle
4837
4838 C<autobundle> writes a bundle file into the
4839 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
4840 a list of all modules that are both available from CPAN and currently
4841 installed within @INC. The name of the bundle file is based on the
4842 current date and a counter.
4843
4844 =head2 recompile
4845
4846 recompile() is a very special command in that it takes no argument and
4847 runs the make/test/install cycle with brute force over all installed
4848 dynamically loadable extensions (aka XS modules) with 'force' in
4849 effect. The primary purpose of this command is to finish a network
4850 installation. Imagine, you have a common source tree for two different
4851 architectures. You decide to do a completely independent fresh
4852 installation. You start on one architecture with the help of a Bundle
4853 file produced earlier. CPAN installs the whole Bundle for you, but
4854 when you try to repeat the job on the second architecture, CPAN
4855 responds with a C<"Foo up to date"> message for all modules. So you
4856 invoke CPAN's recompile on the second architecture and you're done.
4857
4858 Another popular use for C<recompile> is to act as a rescue in case your
4859 perl breaks binary compatibility. If one of the modules that CPAN uses
4860 is in turn depending on binary compatibility (so you cannot run CPAN
4861 commands), then you should try the CPAN::Nox module for recovery.
4862
4863 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
4864
4865 Although it may be considered internal, the class hierarchy does matter
4866 for both users and programmer. CPAN.pm deals with above mentioned four
4867 classes, and all those classes share a set of methods. A classical
4868 single polymorphism is in effect. A metaclass object registers all
4869 objects of all kinds and indexes them with a string. The strings
4870 referencing objects have a separated namespace (well, not completely
4871 separated):
4872
4873          Namespace                         Class
4874
4875    words containing a "/" (slash)      Distribution
4876     words starting with Bundle::          Bundle
4877           everything else            Module or Author
4878
4879 Modules know their associated Distribution objects. They always refer
4880 to the most recent official release. Developers may mark their releases
4881 as unstable development versions (by inserting an underbar into the
4882 visible version number), so the really hottest and newest distribution
4883 file is not always the default.  If a module Foo circulates on CPAN in
4884 both version 1.23 and 1.23_90, CPAN.pm offers a convenient way to
4885 install version 1.23 by saying
4886
4887     install Foo
4888
4889 This would install the complete distribution file (say
4890 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
4891 like to install version 1.23_90, you need to know where the
4892 distribution file resides on CPAN relative to the authors/id/
4893 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
4894 so you would have to say
4895
4896     install BAR/Foo-1.23_90.tar.gz
4897
4898 The first example will be driven by an object of the class
4899 CPAN::Module, the second by an object of class CPAN::Distribution.
4900
4901 =head2 Programmer's interface
4902
4903 If you do not enter the shell, the available shell commands are both
4904 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
4905 functions in the calling package (C<install(...)>).
4906
4907 There's currently only one class that has a stable interface -
4908 CPAN::Shell. All commands that are available in the CPAN shell are
4909 methods of the class CPAN::Shell. Each of the commands that produce
4910 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
4911 the IDs of all modules within the list.
4912
4913 =over 2
4914
4915 =item expand($type,@things)
4916
4917 The IDs of all objects available within a program are strings that can
4918 be expanded to the corresponding real objects with the
4919 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
4920 list of CPAN::Module objects according to the C<@things> arguments
4921 given. In scalar context it only returns the first element of the
4922 list.
4923
4924 =item Programming Examples
4925
4926 This enables the programmer to do operations that combine
4927 functionalities that are available in the shell.
4928
4929     # install everything that is outdated on my disk:
4930     perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
4931
4932     # install my favorite programs if necessary:
4933     for $mod (qw(Net::FTP MD5 Data::Dumper)){
4934         my $obj = CPAN::Shell->expand('Module',$mod);
4935         $obj->install;
4936     }
4937
4938     # list all modules on my disk that have no VERSION number
4939     for $mod (CPAN::Shell->expand("Module","/./")){
4940         next unless $mod->inst_file;
4941         # MakeMaker convention for undefined $VERSION:
4942         next unless $mod->inst_version eq "undef";
4943         print "No VERSION in ", $mod->id, "\n";
4944     }
4945
4946     # find out which distribution on CPAN contains a module:
4947     print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
4948
4949 Or if you want to write a cronjob to watch The CPAN, you could list
4950 all modules that need updating. First a quick and dirty way:
4951
4952     perl -e 'use CPAN; CPAN::Shell->r;'
4953
4954 If you don't want to get any output if all modules are up to date, you
4955 can parse the output of above command for the regular expression
4956 //modules are up to date// and decide to mail the output only if it
4957 doesn't match. Ick?
4958
4959 If you prefer to do it more in a programmer style in one single
4960 process, maybe something like this suites you better:
4961
4962   # list all modules on my disk that have newer versions on CPAN
4963   for $mod (CPAN::Shell->expand("Module","/./")){
4964     next unless $mod->inst_file;
4965     next if $mod->uptodate;
4966     printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
4967         $mod->id, $mod->inst_version, $mod->cpan_version;
4968   }
4969
4970 If that gives you too much output every day, you maybe only want to
4971 watch for three modules. You can write
4972
4973   for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
4974
4975 as the first line instead. Or you can combine some of the above
4976 tricks:
4977
4978   # watch only for a new mod_perl module
4979   $mod = CPAN::Shell->expand("Module","mod_perl");
4980   exit if $mod->uptodate;
4981   # new mod_perl arrived, let me know all update recommendations
4982   CPAN::Shell->r;
4983
4984 =back
4985
4986 =head2 Methods in the four Classes
4987
4988 =head2 Cache Manager
4989
4990 Currently the cache manager only keeps track of the build directory
4991 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
4992 deletes complete directories below C<build_dir> as soon as the size of
4993 all directories there gets bigger than $CPAN::Config->{build_cache}
4994 (in MB). The contents of this cache may be used for later
4995 re-installations that you intend to do manually, but will never be
4996 trusted by CPAN itself. This is due to the fact that the user might
4997 use these directories for building modules on different architectures.
4998
4999 There is another directory ($CPAN::Config->{keep_source_where}) where
5000 the original distribution files are kept. This directory is not
5001 covered by the cache manager and must be controlled by the user. If
5002 you choose to have the same directory as build_dir and as
5003 keep_source_where directory, then your sources will be deleted with
5004 the same fifo mechanism.
5005
5006 =head2 Bundles
5007
5008 A bundle is just a perl module in the namespace Bundle:: that does not
5009 define any functions or methods. It usually only contains documentation.
5010
5011 It starts like a perl module with a package declaration and a $VERSION
5012 variable. After that the pod section looks like any other pod with the
5013 only difference being that I<one special pod section> exists starting with
5014 (verbatim):
5015
5016         =head1 CONTENTS
5017
5018 In this pod section each line obeys the format
5019
5020         Module_Name [Version_String] [- optional text]
5021
5022 The only required part is the first field, the name of a module
5023 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
5024 of the line is optional. The comment part is delimited by a dash just
5025 as in the man page header.
5026
5027 The distribution of a bundle should follow the same convention as
5028 other distributions.
5029
5030 Bundles are treated specially in the CPAN package. If you say 'install
5031 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
5032 the modules in the CONTENTS section of the pod. You can install your
5033 own Bundles locally by placing a conformant Bundle file somewhere into
5034 your @INC path. The autobundle() command which is available in the
5035 shell interface does that for you by including all currently installed
5036 modules in a snapshot bundle file.
5037
5038 =head2 Prerequisites
5039
5040 If you have a local mirror of CPAN and can access all files with
5041 "file:" URLs, then you only need a perl better than perl5.003 to run
5042 this module. Otherwise Net::FTP is strongly recommended. LWP may be
5043 required for non-UNIX systems or if your nearest CPAN site is
5044 associated with an URL that is not C<ftp:>.
5045
5046 If you have neither Net::FTP nor LWP, there is a fallback mechanism
5047 implemented for an external ftp command or for an external lynx
5048 command.
5049
5050 =head2 Finding packages and VERSION
5051
5052 This module presumes that all packages on CPAN
5053
5054 =over 2
5055
5056 =item *
5057
5058 declare their $VERSION variable in an easy to parse manner. This
5059 prerequisite can hardly be relaxed because it consumes far too much
5060 memory to load all packages into the running program just to determine
5061 the $VERSION variable. Currently all programs that are dealing with
5062 version use something like this
5063
5064     perl -MExtUtils::MakeMaker -le \
5065         'print MM->parse_version(shift)' filename
5066
5067 If you are author of a package and wonder if your $VERSION can be
5068 parsed, please try the above method.
5069
5070 =item *
5071
5072 come as compressed or gzipped tarfiles or as zip files and contain a
5073 Makefile.PL (well, we try to handle a bit more, but without much
5074 enthusiasm).
5075
5076 =back
5077
5078 =head2 Debugging
5079
5080 The debugging of this module is pretty difficult, because we have
5081 interferences of the software producing the indices on CPAN, of the
5082 mirroring process on CPAN, of packaging, of configuration, of
5083 synchronicity, and of bugs within CPAN.pm.
5084
5085 In interactive mode you can try "o debug" which will list options for
5086 debugging the various parts of the package. The output may not be very
5087 useful for you as it's just a by-product of my own testing, but if you
5088 have an idea which part of the package may have a bug, it's sometimes
5089 worth to give it a try and send me more specific output. You should
5090 know that "o debug" has built-in completion support.
5091
5092 =head2 Floppy, Zip, Offline Mode
5093
5094 CPAN.pm works nicely without network too. If you maintain machines
5095 that are not networked at all, you should consider working with file:
5096 URLs. Of course, you have to collect your modules somewhere first. So
5097 you might use CPAN.pm to put together all you need on a networked
5098 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
5099 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
5100 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
5101 with this floppy. See also below the paragraph about CD-ROM support.
5102
5103 =head1 CONFIGURATION
5104
5105 When the CPAN module is installed, a site wide configuration file is
5106 created as CPAN/Config.pm. The default values defined there can be
5107 overridden in another configuration file: CPAN/MyConfig.pm. You can
5108 store this file in $HOME/.cpan/CPAN/MyConfig.pm if you want, because
5109 $HOME/.cpan is added to the search path of the CPAN module before the
5110 use() or require() statements.
5111
5112 Currently the following keys in the hash reference $CPAN::Config are
5113 defined:
5114
5115   build_cache        size of cache for directories to build modules
5116   build_dir          locally accessible directory to build modules
5117   index_expire       after this many days refetch index files
5118   cpan_home          local directory reserved for this package
5119   dontload_hash      anonymous hash: modules in the keys will not be
5120                      loaded by the CPAN::has_inst() routine
5121   gzip               location of external program gzip
5122   inactivity_timeout breaks interactive Makefile.PLs after this
5123                      many seconds inactivity. Set to 0 to never break.
5124   inhibit_startup_message
5125                      if true, does not print the startup message
5126   keep_source_where  directory in which to keep the source (if we do)
5127   make               location of external make program
5128   make_arg           arguments that should always be passed to 'make'
5129   make_install_arg   same as make_arg for 'make install'
5130   makepl_arg         arguments passed to 'perl Makefile.PL'
5131   pager              location of external program more (or any pager)
5132   prerequisites_policy
5133                      what to do if you are missing module prerequisites
5134                      ('follow' automatically, 'ask' me, or 'ignore')
5135   scan_cache         controls scanning of cache ('atstart' or 'never')
5136   tar                location of external program tar
5137   unzip              location of external program unzip
5138   urllist            arrayref to nearby CPAN sites (or equivalent locations)
5139   wait_list          arrayref to a wait server to try (See CPAN::WAIT)
5140   ftp_proxy,      }  the three usual variables for configuring
5141     http_proxy,   }  proxy requests. Both as CPAN::Config variables
5142     no_proxy      }  and as environment variables configurable.
5143
5144 You can set and query each of these options interactively in the cpan
5145 shell with the command set defined within the C<o conf> command:
5146
5147 =over 2
5148
5149 =item C<o conf E<lt>scalar optionE<gt>>
5150
5151 prints the current value of the I<scalar option>
5152
5153 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
5154
5155 Sets the value of the I<scalar option> to I<value>
5156
5157 =item C<o conf E<lt>list optionE<gt>>
5158
5159 prints the current value of the I<list option> in MakeMaker's
5160 neatvalue format.
5161
5162 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
5163
5164 shifts or pops the array in the I<list option> variable
5165
5166 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
5167
5168 works like the corresponding perl commands.
5169
5170 =back
5171
5172 =head2 Note on urllist parameter's format
5173
5174 urllist parameters are URLs according to RFC 1738. We do a little
5175 guessing if your URL is not compliant, but if you have problems with file URLs, please try the correct format. Either:
5176
5177     file://localhost/whatever/ftp/pub/CPAN/
5178
5179 or
5180
5181     file:///home/ftp/pub/CPAN/
5182
5183 =head2 urllist parameter has CD-ROM support
5184
5185 The C<urllist> parameter of the configuration table contains a list of
5186 URLs that are to be used for downloading. If the list contains any
5187 C<file> URLs, CPAN always tries to get files from there first. This
5188 feature is disabled for index files. So the recommendation for the
5189 owner of a CD-ROM with CPAN contents is: include your local, possibly
5190 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
5191
5192   o conf urllist push file://localhost/CDROM/CPAN
5193
5194 CPAN.pm will then fetch the index files from one of the CPAN sites
5195 that come at the beginning of urllist. It will later check for each
5196 module if there is a local copy of the most recent version.
5197
5198 Another peculiarity of urllist is that the site that we could
5199 successfully fetch the last file from automatically gets a preference
5200 token and is tried as the first site for the next request. So if you
5201 add a new site at runtime it may happen that the previously preferred
5202 site will be tried another time. This means that if you want to disallow
5203 a site for the next transfer, it must be explicitly removed from
5204 urllist.
5205
5206 =head1 SECURITY
5207
5208 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
5209 install foreign, unmasked, unsigned code on your machine. We compare
5210 to a checksum that comes from the net just as the distribution file
5211 itself. If somebody has managed to tamper with the distribution file,
5212 they may have as well tampered with the CHECKSUMS file. Future
5213 development will go towards strong authentication.
5214
5215 =head1 EXPORT
5216
5217 Most functions in package CPAN are exported per default. The reason
5218 for this is that the primary use is intended for the cpan shell or for
5219 oneliners.
5220
5221 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
5222
5223 To populate a freshly installed perl with my favorite modules is pretty
5224 easiest by maintaining a private bundle definition file. To get a useful
5225 blueprint of a bundle definition file, the command autobundle can be used
5226 on the CPAN shell command line. This command writes a bundle definition
5227 file for all modules that are installed for the currently running perl
5228 interpreter. It's recommended to run this command only once and from then
5229 on maintain the file manually under a private name, say
5230 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
5231
5232     cpan> install Bundle::my_bundle
5233
5234 then answer a few questions and then go out for a coffee.
5235
5236 Maintaining a bundle definition file means to keep track of two
5237 things: dependencies and interactivity. CPAN.pm sometimes fails on
5238 calculating dependencies because not all modules define all MakeMaker
5239 attributes correctly, so a bundle definition file should specify
5240 prerequisites as early as possible. On the other hand, it's a bit
5241 annoying that many distributions need some interactive configuring. So
5242 what I try to accomplish in my private bundle file is to have the
5243 packages that need to be configured early in the file and the gentle
5244 ones later, so I can go out after a few minutes and leave CPAN.pm
5245 unattained.
5246
5247 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
5248
5249 Thanks to Graham Barr for contributing the following paragraphs about
5250 the interaction between perl, and various firewall configurations. For
5251 further informations on firewalls, it is recommended to consult the
5252 documentation that comes with the ncftp program. If you are unable to
5253 go through the firewall with a simple Perl setup, it is very likely
5254 that you can configure ncftp so that it works for your firewall.
5255
5256 =head2 Three basic types of firewalls
5257
5258 Firewalls can be categorized into three basic types.
5259
5260 =over
5261
5262 =item http firewall
5263
5264 This is where the firewall machine runs a web server and to access the
5265 outside world you must do it via the web server. If you set environment
5266 variables like http_proxy or ftp_proxy to a values beginning with http://
5267 or in your web browser you have to set proxy information then you know
5268 you are running a http firewall.
5269
5270 To access servers outside these types of firewalls with perl (even for
5271 ftp) you will need to use LWP.
5272
5273 =item ftp firewall
5274
5275 This where the firewall machine runs a ftp server. This kind of
5276 firewall will only let you access ftp servers outside the firewall.
5277 This is usually done by connecting to the firewall with ftp, then
5278 entering a username like "user@outside.host.com"
5279
5280 To access servers outside these type of firewalls with perl you
5281 will need to use Net::FTP.
5282
5283 =item One way visibility
5284
5285 I say one way visibility as these firewalls try to make themselve look
5286 invisible to the users inside the firewall. An FTP data connection is
5287 normally created by sending the remote server your IP address and then
5288 listening for the connection. But the remote server will not be able to
5289 connect to you because of the firewall. So for these types of firewall
5290 FTP connections need to be done in a passive mode.
5291
5292 There are two that I can think off.
5293
5294 =over
5295
5296 =item SOCKS
5297
5298 If you are using a SOCKS firewall you will need to compile perl and link
5299 it with the SOCKS library, this is what is normally called a ``socksified''
5300 perl. With this executable you will be able to connect to servers outside
5301 the firewall as if it is not there.
5302
5303 =item IP Masquerade
5304
5305 This is the firewall implemented in the Linux kernel, it allows you to
5306 hide a complete network behind one IP address. With this firewall no
5307 special compiling is need as you can access hosts directly.
5308
5309 =back
5310
5311 =back
5312
5313 =head2 Configuring lynx or ncftp for going throught the firewall
5314
5315 If you can go through your firewall with e.g. lynx, presumably with a
5316 command such as
5317
5318     /usr/local/bin/lynx -pscott:tiger
5319
5320 then you would configure CPAN.pm with the command
5321
5322     o conf lynx "/usr/local/bin/lynx -pscott:tiger"
5323
5324 That's all. Similarly for ncftp or ftp, you would configure something
5325 like
5326
5327     o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
5328
5329 Your milage may vary...
5330
5331 =head1 FAQ
5332
5333 =over
5334
5335 =item I installed a new version of module X but CPAN keeps saying, I
5336       have the old version installed
5337
5338 Most probably you B<do> have the old version installed. This can
5339 happen if a module installs itself into a different directory in the
5340 @INC path than it was previously installed. This is not really a
5341 CPAN.pm problem, you would have the same problem when installing the
5342 module manually. The easiest way to prevent this behaviour is to add
5343 the argument C<UNINST=1> to the C<make install> call, and that is why
5344 many people add this argument permanently by configuring
5345
5346   o conf make_install_arg UNINST=1
5347
5348 =item So why is UNINST=1 not the default?
5349
5350 Because there are people who have their precise expectations about who
5351 may install where in the @INC path and who uses which @INC array. In
5352 fine tuned environments C<UNINST=1> can cause damage.
5353
5354 =item When I install bundles or multiple modules with one command
5355       there is too much output to keep track of
5356
5357 You may want to configure something like
5358
5359   o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
5360   o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
5361
5362 so that STDOUT is captured in a file for later inspection.
5363
5364 =back
5365
5366 =head1 BUGS
5367
5368 We should give coverage for B<all> of the CPAN and not just the PAUSE
5369 part, right? In this discussion CPAN and PAUSE have become equal --
5370 but they are not. PAUSE is authors/ and modules/. CPAN is PAUSE plus
5371 the clpa/, doc/, misc/, ports/, src/, scripts/.
5372
5373 Future development should be directed towards a better integration of
5374 the other parts.
5375
5376 If a Makefile.PL requires special customization of libraries, prompts
5377 the user for special input, etc. then you may find CPAN is not able to
5378 build the distribution. In that case, you should attempt the
5379 traditional method of building a Perl module package from a shell.
5380
5381 =head1 AUTHOR
5382
5383 Andreas Koenig E<lt>andreas.koenig@anima.deE<gt>
5384
5385 =head1 SEE ALSO
5386
5387 perl(1), CPAN::Nox(3)
5388
5389 =cut
5390