lib/CPAN.pm

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