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