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.3901';
   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     local($/) = "\n";
2391     while (<FH>) {
2392         chomp;
2393         my($userid,$fullname,$email) =
2394             /alias\s+(\S+)\s+\"([^\"\<]+)\s+<([^\>]+)\>\"/;
2395         next unless $userid && $fullname && $email;
2396
2397         # instantiate an author object
2398         my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
2399         $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
2400         return if $CPAN::Signal;
2401     }
2402 }
2403
2404 sub userid {
2405   my($self,$dist) = @_;
2406   $dist = $self->{'id'} unless defined $dist;
2407   my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
2408   $ret;
2409 }
2410
2411 #-> sub CPAN::Index::rd_modpacks ;
2412 sub rd_modpacks {
2413     my($cl,$index_target) = @_;
2414     return unless defined $index_target;
2415     $CPAN::Frontend->myprint("Going to read $index_target\n");
2416     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
2417     local($/) = "\n";
2418     while ($_ = $fh->READLINE) {
2419         last if /^\s*$/;
2420     }
2421     while ($_ = $fh->READLINE) {
2422         chomp;
2423         my($mod,$version,$dist) = split;
2424 ###     $version =~ s/^\+//;
2425
2426         # if it is a bundle, instatiate a bundle object
2427         my($bundle,$id,$userid);
2428
2429         if ($mod eq 'CPAN' &&
2430             ! (
2431                $CPAN::META->exists('CPAN::Queue','Bundle::CPAN') ||
2432                $CPAN::META->exists('CPAN::Queue','CPAN')
2433               )
2434            ) {
2435             local($^W)= 0;
2436             if ($version > $CPAN::VERSION){
2437                 $CPAN::Frontend->myprint(qq{
2438   There\'s a new CPAN.pm version (v$version) available!
2439   You might want to try
2440     install Bundle::CPAN
2441     reload cpan
2442   without quitting the current session. It should be a seamless upgrade
2443   while we are running...
2444 });
2445                 sleep 2;
2446                 $CPAN::Frontend->myprint(qq{\n});
2447             }
2448             last if $CPAN::Signal;
2449         } elsif ($mod =~ /^Bundle::(.*)/) {
2450             $bundle = $1;
2451         }
2452
2453         if ($bundle){
2454             $id =  $CPAN::META->instance('CPAN::Bundle',$mod);
2455             # Let's make it a module too, because bundles have so much
2456             # in common with modules
2457             $CPAN::META->instance('CPAN::Module',$mod);
2458
2459 # This "next" makes us faster but if the job is running long, we ignore
2460 # rereads which is bad. So we have to be a bit slower again.
2461 #       } elsif ($CPAN::META->exists('CPAN::Module',$mod)) {
2462 #           next;
2463
2464         }
2465         else {
2466             # instantiate a module object
2467             $id = $CPAN::META->instance('CPAN::Module',$mod);
2468         }
2469
2470         if ($id->cpan_file ne $dist){
2471             $userid = $cl->userid($dist);
2472             $id->set(
2473                      'CPAN_USERID' => $userid,
2474                      'CPAN_VERSION' => $version,
2475                      'CPAN_FILE' => $dist
2476                     );
2477         }
2478
2479         # instantiate a distribution object
2480         unless ($CPAN::META->exists('CPAN::Distribution',$dist)) {
2481             $CPAN::META->instance(
2482                                   'CPAN::Distribution' => $dist
2483                                  )->set(
2484                                         'CPAN_USERID' => $userid
2485                                        );
2486         }
2487
2488         return if $CPAN::Signal;
2489     }
2490     undef $fh;
2491 }
2492
2493 #-> sub CPAN::Index::rd_modlist ;
2494 sub rd_modlist {
2495     my($cl,$index_target) = @_;
2496     return unless defined $index_target;
2497     $CPAN::Frontend->myprint("Going to read $index_target\n");
2498     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
2499     my @eval;
2500     local($/) = "\n";
2501     while ($_ = $fh->READLINE) {
2502         if (/^Date:\s+(.*)/){
2503             return if $date_of_03 eq $1;
2504             ($date_of_03) = $1;
2505         }
2506         last if /^\s*$/;
2507     }
2508     push @eval, $_ while $_ = $fh->READLINE;
2509     undef $fh;
2510     push @eval, q{CPAN::Modulelist->data;};
2511     local($^W) = 0;
2512     my($comp) = Safe->new("CPAN::Safe1");
2513     my($eval) = join("", @eval);
2514     my $ret = $comp->reval($eval);
2515     Carp::confess($@) if $@;
2516     return if $CPAN::Signal;
2517     for (keys %$ret) {
2518         my $obj = $CPAN::META->instance(CPAN::Module,$_);
2519         $obj->set(%{$ret->{$_}});
2520         return if $CPAN::Signal;
2521     }
2522 }
2523
2524 package CPAN::InfoObj;
2525
2526 #-> sub CPAN::InfoObj::new ;
2527 sub new { my $this = bless {}, shift; %$this = @_; $this }
2528
2529 #-> sub CPAN::InfoObj::set ;
2530 sub set {
2531     my($self,%att) = @_;
2532     my(%oldatt) = %$self;
2533     %$self = (%oldatt, %att);
2534 }
2535
2536 #-> sub CPAN::InfoObj::id ;
2537 sub id { shift->{'ID'} }
2538
2539 #-> sub CPAN::InfoObj::as_glimpse ;
2540 sub as_glimpse {
2541     my($self) = @_;
2542     my(@m);
2543     my $class = ref($self);
2544     $class =~ s/^CPAN:://;
2545     push @m, sprintf "%-15s %s\n", $class, $self->{ID};
2546     join "", @m;
2547 }
2548
2549 #-> sub CPAN::InfoObj::as_string ;
2550 sub as_string {
2551     my($self) = @_;
2552     my(@m);
2553     my $class = ref($self);
2554     $class =~ s/^CPAN:://;
2555     push @m, $class, " id = $self->{ID}\n";
2556     for (sort keys %$self) {
2557         next if $_ eq 'ID';
2558         my $extra = "";
2559         if ($_ eq "CPAN_USERID") {
2560           $extra .= " (".$self->author;
2561           my $email; # old perls!
2562           if ($email = $CPAN::META->instance(CPAN::Author,
2563                                                 $self->{$_}
2564                                                )->email) {
2565             $extra .= " <$email>";
2566           } else {
2567             $extra .= " <no email>";
2568           }
2569           $extra .= ")";
2570         }
2571         if (ref($self->{$_}) eq "ARRAY") { # language interface? XXX
2572             push @m, sprintf "    %-12s %s%s\n", $_, "@{$self->{$_}}", $extra;
2573         } else {
2574             push @m, sprintf "    %-12s %s%s\n", $_, $self->{$_}, $extra;
2575         }
2576     }
2577     join "", @m, "\n";
2578 }
2579
2580 #-> sub CPAN::InfoObj::author ;
2581 sub author {
2582     my($self) = @_;
2583     $CPAN::META->instance(CPAN::Author,$self->{CPAN_USERID})->fullname;
2584 }
2585
2586 package CPAN::Author;
2587
2588 #-> sub CPAN::Author::as_glimpse ;
2589 sub as_glimpse {
2590     my($self) = @_;
2591     my(@m);
2592     my $class = ref($self);
2593     $class =~ s/^CPAN:://;
2594     push @m, sprintf "%-15s %s (%s)\n", $class, $self->{ID}, $self->fullname;
2595     join "", @m;
2596 }
2597
2598 # Dead code, I would have liked to have,,, but it was never reached,,,
2599 #sub make {
2600 #    my($self) = @_;
2601 #    return "Don't be silly, you can't make $self->{FULLNAME} ;-)\n";
2602 #}
2603
2604 #-> sub CPAN::Author::fullname ;
2605 sub fullname { shift->{'FULLNAME'} }
2606 *name = \&fullname;
2607 #-> sub CPAN::Author::email ;
2608 sub email    { shift->{'EMAIL'} }
2609
2610 package CPAN::Distribution;
2611
2612 #-> sub CPAN::Distribution::called_for ;
2613 sub called_for {
2614     my($self,$id) = @_;
2615     $self->{'CALLED_FOR'} = $id if defined $id;
2616     return $self->{'CALLED_FOR'};
2617 }
2618
2619 #-> sub CPAN::Distribution::get ;
2620 sub get {
2621     my($self) = @_;
2622   EXCUSE: {
2623         my @e;
2624         exists $self->{'build_dir'} and push @e,
2625             "Unwrapped into directory $self->{'build_dir'}";
2626         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
2627     }
2628     my($local_file);
2629     my($local_wanted) =
2630          MM->catfile(
2631                         $CPAN::Config->{keep_source_where},
2632                         "authors",
2633                         "id",
2634                         split("/",$self->{ID})
2635                        );
2636
2637     $self->debug("Doing localize") if $CPAN::DEBUG;
2638     $local_file =
2639         CPAN::FTP->localize("authors/id/$self->{ID}", $local_wanted)
2640             or $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n");
2641     $self->{localfile} = $local_file;
2642     my $builddir = $CPAN::META->{cachemgr}->dir;
2643     $self->debug("doing chdir $builddir") if $CPAN::DEBUG;
2644     chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
2645     my $packagedir;
2646
2647     $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
2648     if ($CPAN::META->has_inst('MD5')) {
2649         $self->debug("MD5 is installed, verifying");
2650         $self->verifyMD5;
2651     } else {
2652         $self->debug("MD5 is NOT installed");
2653     }
2654     $self->debug("Removing tmp") if $CPAN::DEBUG;
2655     File::Path::rmtree("tmp");
2656     mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
2657     chdir "tmp";
2658     $self->debug("Changed directory to tmp") if $CPAN::DEBUG;
2659     if (! $local_file) {
2660         Carp::croak "bad download, can't do anything :-(\n";
2661     } elsif ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)$/i){
2662         $self->untar_me($local_file);
2663     } elsif ( $local_file =~ /\.zip$/i ) {
2664         $self->unzip_me($local_file);
2665     } elsif ( $local_file =~ /\.pm\.(gz|Z)$/) {
2666         $self->pm2dir_me($local_file);
2667     } else {
2668         $self->{archived} = "NO";
2669     }
2670     chdir "..";
2671     if ($self->{archived} ne 'NO') {
2672         chdir "tmp";
2673         # Let's check if the package has its own directory.
2674         my $dh = DirHandle->new(".") or Carp::croak("Couldn't opendir .: $!");
2675         my @readdir = grep $_ !~ /^\.\.?$/, $dh->read; ### MAC??
2676         $dh->close;
2677         my ($distdir,$packagedir);
2678         if (@readdir == 1 && -d $readdir[0]) {
2679             $distdir = $readdir[0];
2680             $packagedir = MM->catdir($builddir,$distdir);
2681             -d $packagedir and $CPAN::Frontend->myprint("Removing previously used $packagedir\n");
2682             File::Path::rmtree($packagedir);
2683             rename($distdir,$packagedir) or Carp::confess("Couldn't rename $distdir to $packagedir: $!");
2684         } else {
2685             my $pragmatic_dir = $self->{'CPAN_USERID'} . '000';
2686             $pragmatic_dir =~ s/\W_//g;
2687             $pragmatic_dir++ while -d "../$pragmatic_dir";
2688             $packagedir = MM->catdir($builddir,$pragmatic_dir);
2689             File::Path::mkpath($packagedir);
2690             my($f);
2691             for $f (@readdir) { # is already without "." and ".."
2692                 my $to = MM->catdir($packagedir,$f);
2693                 rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
2694             }
2695         }
2696         $self->{'build_dir'} = $packagedir;
2697         chdir "..";
2698
2699         $self->debug("Changed directory to .. (self is $self [".$self->as_string."])")
2700             if $CPAN::DEBUG;
2701         File::Path::rmtree("tmp");
2702         if ($CPAN::Config->{keep_source_where} =~ /^no/i ){
2703             $CPAN::Frontend->myprint("Going to unlink $local_file\n");
2704             unlink $local_file or Carp::carp "Couldn't unlink $local_file";
2705         }
2706         my($makefilepl) = MM->catfile($packagedir,"Makefile.PL");
2707         unless (-f $makefilepl) {
2708           my($configure) = MM->catfile($packagedir,"Configure");
2709           if (-f $configure) {
2710             # do we have anything to do?
2711             $self->{'configure'} = $configure;
2712           } elsif (-f MM->catfile($packagedir,"Makefile")) {
2713             $CPAN::Frontend->myprint(qq{
2714 Package comes with a Makefile and without a Makefile.PL.
2715 We\'ll try to build it with that Makefile then.
2716 });
2717             $self->{writemakefile} = "YES";
2718             sleep 2;
2719           } else {
2720             my $fh = FileHandle->new(">$makefilepl")
2721                 or Carp::croak("Could not open >$makefilepl");
2722             my $cf = $self->called_for || "unknown";
2723             $fh->print(
2724 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
2725 # because there was no Makefile.PL supplied.
2726 # Autogenerated on: }.scalar localtime().qq{
2727
2728 use ExtUtils::MakeMaker;
2729 WriteMakefile(NAME => q[$cf]);
2730
2731 });
2732             $CPAN::Frontend->myprint(qq{Package comes without Makefile.PL.
2733   Writing one on our own (calling it $cf)\n});
2734             }
2735         }
2736     }
2737     return $self;
2738 }
2739
2740 sub untar_me {
2741     my($self,$local_file) = @_;
2742     $self->{archived} = "tar";
2743     if (CPAN::Tarzip->untar($local_file)) {
2744         $self->{unwrapped} = "YES";
2745     } else {
2746         $self->{unwrapped} = "NO";
2747     }
2748 }
2749
2750 sub unzip_me {
2751     my($self,$local_file) = @_;
2752     $self->{archived} = "zip";
2753     my $system = "$CPAN::Config->{unzip} $local_file";
2754     if (system($system) == 0) {
2755         $self->{unwrapped} = "YES";
2756     } else {
2757         $self->{unwrapped} = "NO";
2758     }
2759 }
2760
2761 sub pm2dir_me {
2762     my($self,$local_file) = @_;
2763     $self->{archived} = "pm";
2764     my $to = File::Basename::basename($local_file);
2765     $to =~ s/\.(gz|Z)$//;
2766     if (CPAN::Tarzip->gunzip($local_file,$to)) {
2767         $self->{unwrapped} = "YES";
2768     } else {
2769         $self->{unwrapped} = "NO";
2770     }
2771 }
2772
2773 #-> sub CPAN::Distribution::new ;
2774 sub new {
2775     my($class,%att) = @_;
2776
2777     $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
2778
2779     my $this = { %att };
2780     return bless $this, $class;
2781 }
2782
2783 #-> sub CPAN::Distribution::look ;
2784 sub look {
2785     my($self) = @_;
2786     if (  $CPAN::Config->{'shell'} ) {
2787         $CPAN::Frontend->myprint(qq{
2788 Trying to open a subshell in the build directory...
2789 });
2790     } else {
2791         $CPAN::Frontend->myprint(qq{
2792 Your configuration does not define a value for subshells.
2793 Please define it with "o conf shell <your shell>"
2794 });
2795         return;
2796     }
2797     my $dist = $self->id;
2798     my $dir  = $self->dir or $self->get;
2799     $dir = $self->dir;
2800     my $getcwd;
2801     $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
2802     my $pwd  = CPAN->$getcwd();
2803     chdir($dir);
2804     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
2805     system($CPAN::Config->{'shell'}) == 0
2806         or $CPAN::Frontend->mydie("Subprocess shell error");
2807     chdir($pwd);
2808 }
2809
2810 #-> sub CPAN::Distribution::readme ;
2811 sub readme {
2812     my($self) = @_;
2813     my($dist) = $self->id;
2814     my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
2815     $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
2816     my($local_file);
2817     my($local_wanted) =
2818          MM->catfile(
2819                         $CPAN::Config->{keep_source_where},
2820                         "authors",
2821                         "id",
2822                         split("/","$sans.readme"),
2823                        );
2824     $self->debug("Doing localize") if $CPAN::DEBUG;
2825     $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
2826                                       $local_wanted)
2827         or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
2828     my $fh_pager = FileHandle->new;
2829     local($SIG{PIPE}) = "IGNORE";
2830     $fh_pager->open("|$CPAN::Config->{'pager'}")
2831         or die "Could not open pager $CPAN::Config->{'pager'}: $!";
2832     my $fh_readme = FileHandle->new;
2833     $fh_readme->open($local_file)
2834         or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
2835     $CPAN::Frontend->myprint(qq{
2836 Displaying file
2837   $local_file
2838 with pager "$CPAN::Config->{'pager'}"
2839 });
2840     sleep 2;
2841     $fh_pager->print(<$fh_readme>);
2842 }
2843
2844 #-> sub CPAN::Distribution::verifyMD5 ;
2845 sub verifyMD5 {
2846     my($self) = @_;
2847   EXCUSE: {
2848         my @e;
2849         $self->{MD5_STATUS} ||= "";
2850         $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
2851         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
2852     }
2853     my($lc_want,$lc_file,@local,$basename);
2854     @local = split("/",$self->{ID});
2855     pop @local;
2856     push @local, "CHECKSUMS";
2857     $lc_want =
2858         MM->catfile($CPAN::Config->{keep_source_where},
2859                       "authors", "id", @local);
2860     local($") = "/";
2861     if (
2862         -s $lc_want
2863         &&
2864         $self->MD5_check_file($lc_want)
2865        ) {
2866         return $self->{MD5_STATUS} = "OK";
2867     }
2868     $lc_file = CPAN::FTP->localize("authors/id/@local",
2869                                    $lc_want,1);
2870     unless ($lc_file) {
2871         $local[-1] .= ".gz";
2872         $lc_file = CPAN::FTP->localize("authors/id/@local",
2873                                        "$lc_want.gz",1);
2874         if ($lc_file) {
2875             $lc_file =~ s/\.gz$//;
2876             CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
2877         } else {
2878             return;
2879         }
2880     }
2881     $self->MD5_check_file($lc_file);
2882 }
2883
2884 #-> sub CPAN::Distribution::MD5_check_file ;
2885 sub MD5_check_file {
2886     my($self,$chk_file) = @_;
2887     my($cksum,$file,$basename);
2888     $file = $self->{localfile};
2889     $basename = File::Basename::basename($file);
2890     my $fh = FileHandle->new;
2891     if (open $fh, $chk_file){
2892         local($/);
2893         my $eval = <$fh>;
2894         close $fh;
2895         my($comp) = Safe->new();
2896         $cksum = $comp->reval($eval);
2897         if ($@) {
2898             rename $chk_file, "$chk_file.bad";
2899             Carp::confess($@) if $@;
2900         }
2901     } else {
2902         Carp::carp "Could not open $chk_file for reading";
2903     }
2904
2905     if (exists $cksum->{$basename}{md5}) {
2906         $self->debug("Found checksum for $basename:" .
2907                      "$cksum->{$basename}{md5}\n") if $CPAN::DEBUG;
2908
2909         open($fh, $file);
2910         binmode $fh;
2911         my $eq = $self->eq_MD5($fh,$cksum->{$basename}{'md5'});
2912         $fh->close;
2913         $fh = CPAN::Tarzip->TIEHANDLE($file);
2914
2915         unless ($eq) {
2916           # had to inline it, when I tied it, the tiedness got lost on
2917           # the call to eq_MD5. (Jan 1998)
2918           my $md5 = MD5->new;
2919           my($data,$ref);
2920           $ref = \$data;
2921           while ($fh->READ($ref, 4096)){
2922             $md5->add($data);
2923           }
2924           my $hexdigest = $md5->hexdigest;
2925           $eq += $hexdigest eq $cksum->{$basename}{'md5-ungz'};
2926         }
2927
2928         if ($eq) {
2929           $CPAN::Frontend->myprint("Checksum for $file ok\n");
2930           return $self->{MD5_STATUS} = "OK";
2931         } else {
2932             $CPAN::Frontend->myprint(qq{Checksum mismatch for }.
2933                                      qq{distribution file. }.
2934                                      qq{Please investigate.\n\n}.
2935                                      $self->as_string,
2936                                      $CPAN::META->instance(
2937                                                            'CPAN::Author',
2938                                                            $self->{CPAN_USERID}
2939                                                           )->as_string);
2940             my $wrap = qq{I\'d recommend removing $file. It seems to
2941 be a bogus file. Maybe you have configured your \`urllist\' with a
2942 bad URL. Please check this array with \`o conf urllist\', and
2943 retry.};
2944             $CPAN::Frontend->myprint(Text::Wrap::wrap("","",$wrap));
2945             $CPAN::Frontend->myprint("\n\n");
2946             sleep 3;
2947             return;
2948         }
2949         # close $fh if fileno($fh);
2950     } else {
2951         $self->{MD5_STATUS} ||= "";
2952         if ($self->{MD5_STATUS} eq "NIL") {
2953             $CPAN::Frontend->myprint(qq{
2954 No md5 checksum for $basename in local $chk_file.
2955 Removing $chk_file
2956 });
2957             unlink $chk_file or $CPAN::Frontend->myprint("Could not unlink: $!");
2958             sleep 1;
2959         }
2960         $self->{MD5_STATUS} = "NIL";
2961         return;
2962     }
2963 }
2964
2965 #-> sub CPAN::Distribution::eq_MD5 ;
2966 sub eq_MD5 {
2967     my($self,$fh,$expectMD5) = @_;
2968     my $md5 = MD5->new;
2969     my($data);
2970     while (read($fh, $data, 4096)){
2971       $md5->add($data);
2972     }
2973     # $md5->addfile($fh);
2974     my $hexdigest = $md5->hexdigest;
2975     # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
2976     $hexdigest eq $expectMD5;
2977 }
2978
2979 #-> sub CPAN::Distribution::force ;
2980 sub force {
2981     my($self) = @_;
2982     $self->{'force_update'}++;
2983     delete $self->{'MD5_STATUS'};
2984     delete $self->{'archived'};
2985     delete $self->{'build_dir'};
2986     delete $self->{'localfile'};
2987     delete $self->{'make'};
2988     delete $self->{'install'};
2989     delete $self->{'unwrapped'};
2990     delete $self->{'writemakefile'};
2991 }
2992
2993 sub isa_perl {
2994   my($self) = @_;
2995   my $file = File::Basename::basename($self->id);
2996   return unless $file =~ m{ ^ perl
2997                             (5)
2998                             ([._-])
2999                             (\d{3}(_[0-4][0-9])?)
3000                             \.tar[._-]gz
3001                             $
3002                           }x;
3003   "$1.$3";
3004 }
3005
3006 #-> sub CPAN::Distribution::perl ;
3007 sub perl {
3008     my($self) = @_;
3009     my($perl) = MM->file_name_is_absolute($^X) ? $^X : "";
3010     my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
3011     my $pwd  = CPAN->$getcwd();
3012     my $candidate = MM->catfile($pwd,$^X);
3013     $perl ||= $candidate if MM->maybe_command($candidate);
3014     unless ($perl) {
3015         my ($component,$perl_name);
3016       DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
3017             PATH_COMPONENT: foreach $component (MM->path(),
3018                                                 $Config::Config{'binexp'}) {
3019                   next unless defined($component) && $component;
3020                   my($abs) = MM->catfile($component,$perl_name);
3021                   if (MM->maybe_command($abs)) {
3022                       $perl = $abs;
3023                       last DIST_PERLNAME;
3024                   }
3025               }
3026           }
3027     }
3028     $perl;
3029 }
3030
3031 #-> sub CPAN::Distribution::make ;
3032 sub make {
3033     my($self) = @_;
3034     $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id);
3035     # Emergency brake if they said install Pippi and get newest perl
3036     if ($self->isa_perl) {
3037       if (
3038           $self->called_for ne $self->id && ! $self->{'force_update'}
3039          ) {
3040         $CPAN::Frontend->mydie(sprintf qq{
3041 The most recent version "%s" of the module "%s"
3042 comes with the current version of perl (%s).
3043 I\'ll build that only if you ask for something like
3044     force install %s
3045 or
3046     install %s
3047 },
3048                                $CPAN::META->instance(
3049                                                      'CPAN::Module',
3050                                                      $self->called_for
3051                                                     )->cpan_version,
3052                                $self->called_for,
3053                                $self->isa_perl,
3054                                $self->called_for,
3055                                $self->id);
3056       }
3057     }
3058     $self->get;
3059   EXCUSE: {
3060         my @e;
3061         $self->{archived} eq "NO" and push @e,
3062         "Is neither a tar nor a zip archive.";
3063
3064         $self->{unwrapped} eq "NO" and push @e,
3065         "had problems unarchiving. Please build manually";
3066
3067         exists $self->{writemakefile} &&
3068             $self->{writemakefile} eq "NO" and push @e,
3069             "Had some problem writing Makefile";
3070
3071         defined $self->{'make'} and push @e,
3072         "Has already been processed within this session";
3073
3074         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
3075     }
3076     $CPAN::Frontend->myprint("\n  CPAN.pm: Going to build ".$self->id."\n\n");
3077     my $builddir = $self->dir;
3078     chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
3079     $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
3080
3081     my $system;
3082     if ($self->{'configure'}) {
3083       $system = $self->{'configure'};
3084     } else {
3085         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
3086         my $switch = "";
3087 # This needs a handler that can be turned on or off:
3088 #       $switch = "-MExtUtils::MakeMaker ".
3089 #           "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
3090 #           if $] > 5.00310;
3091         $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
3092     }
3093     unless (exists $self->{writemakefile}) {
3094         local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
3095         my($ret,$pid);
3096         $@ = "";
3097         if ($CPAN::Config->{inactivity_timeout}) {
3098             eval {
3099                 alarm $CPAN::Config->{inactivity_timeout};
3100                 local $SIG{CHLD} = sub { wait };
3101                 if (defined($pid = fork)) {
3102                     if ($pid) { #parent
3103                         wait;
3104                     } else {    #child
3105                       # note, this exec isn't necessary if
3106                       # inactivity_timeout is 0. On the Mac I'd
3107                       # suggest, we set it always to 0.
3108                       exec $system;
3109                     }
3110                 } else {
3111                     $CPAN::Frontend->myprint("Cannot fork: $!");
3112                     return;
3113                 }
3114             };
3115             alarm 0;
3116             if ($@){
3117                 kill 9, $pid;
3118                 waitpid $pid, 0;
3119                 $CPAN::Frontend->myprint($@);
3120                 $self->{writemakefile} = "NO - $@";
3121                 $@ = "";
3122                 return;
3123             }
3124         } else {
3125           if (0) {
3126             warn "Trying to intercept the output of 'perl Makefile.PL'";
3127             require IO::File;
3128             # my $fh = FileHandle->new("$system 2>&1 |") or
3129             my $fh = IO::File->new("$system 2>&1 |") or
3130                 die "Couldn't run '$system': $!";
3131             local($|) = 1;
3132             while (length($_ = getc($fh))) {
3133               print $_; # we want to parse that some day!
3134               # unfortunately we have Makefile.PLs that want to talk
3135               # and we can't emulate that reliably. I think, we have
3136               # to parse Makefile.PL directly
3137             }
3138             $ret = $fh->close;
3139             unless ($ret) {
3140               warn $! ? "Error during 'perl Makefile.PL' subprocess: $!" :
3141                   "Exit status of 'perl Makefile.PL': $?";
3142               $self->{writemakefile} = "NO";
3143               return;
3144             }
3145           } else {
3146             $ret = system($system);
3147             if ($ret != 0) {
3148               $self->{writemakefile} = "NO";
3149               return;
3150             }
3151           }
3152         }
3153         $self->{writemakefile} = "YES";
3154     }
3155     return if $CPAN::Signal;
3156     $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
3157     if (system($system) == 0) {
3158          $CPAN::Frontend->myprint("  $system -- OK\n");
3159          $self->{'make'} = "YES";
3160     } else {
3161          $self->{writemakefile} = "YES";
3162          $self->{'make'} = "NO";
3163          $CPAN::Frontend->myprint("  $system -- NOT OK\n");
3164     }
3165 }
3166
3167 #-> sub CPAN::Distribution::test ;
3168 sub test {
3169     my($self) = @_;
3170     $self->make;
3171     return if $CPAN::Signal;
3172     $CPAN::Frontend->myprint("Running make test\n");
3173   EXCUSE: {
3174         my @e;
3175         exists $self->{'make'} or push @e,
3176         "Make had some problems, maybe interrupted? Won't test";
3177
3178         exists $self->{'make'} and
3179             $self->{'make'} eq 'NO' and
3180                 push @e, "Oops, make had returned bad status";
3181
3182         exists $self->{'build_dir'} or push @e, "Has no own directory";
3183         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
3184     }
3185     chdir $self->{'build_dir'} or
3186         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
3187     $self->debug("Changed directory to $self->{'build_dir'}")
3188         if $CPAN::DEBUG;
3189     my $system = join " ", $CPAN::Config->{'make'}, "test";
3190     if (system($system) == 0) {
3191          $CPAN::Frontend->myprint("  $system -- OK\n");
3192          $self->{'make_test'} = "YES";
3193     } else {
3194          $self->{'make_test'} = "NO";
3195          $CPAN::Frontend->myprint("  $system -- NOT OK\n");
3196     }
3197 }
3198
3199 #-> sub CPAN::Distribution::clean ;
3200 sub clean {
3201     my($self) = @_;
3202     $CPAN::Frontend->myprint("Running make clean\n");
3203   EXCUSE: {
3204         my @e;
3205         exists $self->{'build_dir'} or push @e, "Has no own directory";
3206         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
3207     }
3208     chdir $self->{'build_dir'} or
3209         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
3210     $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
3211     my $system = join " ", $CPAN::Config->{'make'}, "clean";
3212     if (system($system) == 0) {
3213         $CPAN::Frontend->myprint("  $system -- OK\n");
3214         $self->force;
3215     } else {
3216         # Hmmm, what to do if make clean failed?
3217     }
3218 }
3219
3220 #-> sub CPAN::Distribution::install ;
3221 sub install {
3222     my($self) = @_;
3223     $self->test;
3224     return if $CPAN::Signal;
3225     $CPAN::Frontend->myprint("Running make install\n");
3226   EXCUSE: {
3227         my @e;
3228         exists $self->{'build_dir'} or push @e, "Has no own directory";
3229
3230         exists $self->{'make'} or push @e,
3231         "Make had some problems, maybe interrupted? Won't install";
3232
3233         exists $self->{'make'} and
3234             $self->{'make'} eq 'NO' and
3235                 push @e, "Oops, make had returned bad status";
3236
3237         push @e, "make test had returned bad status, ".
3238             "won't install without force"
3239             if exists $self->{'make_test'} and
3240             $self->{'make_test'} eq 'NO' and
3241             ! $self->{'force_update'};
3242
3243         exists $self->{'install'} and push @e,
3244         $self->{'install'} eq "YES" ?
3245             "Already done" : "Already tried without success";
3246
3247         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
3248     }
3249     chdir $self->{'build_dir'} or
3250         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
3251     $self->debug("Changed directory to $self->{'build_dir'}")
3252         if $CPAN::DEBUG;
3253     my $system = join(" ", $CPAN::Config->{'make'},
3254                       "install", $CPAN::Config->{make_install_arg});
3255     my($pipe) = FileHandle->new("$system 2>&1 |");
3256     my($makeout) = "";
3257     while (<$pipe>){
3258         $CPAN::Frontend->myprint($_);
3259         $makeout .= $_;
3260     }
3261     $pipe->close;
3262     if ($?==0) {
3263          $CPAN::Frontend->myprint("  $system -- OK\n");
3264          $self->{'install'} = "YES";
3265     } else {
3266          $self->{'install'} = "NO";
3267          $CPAN::Frontend->myprint("  $system -- NOT OK\n");
3268          if ($makeout =~ /permission/s && $> > 0) {
3269              $CPAN::Frontend->myprint(qq{    You may have to su }.
3270                                       qq{to root to install the package\n});
3271          }
3272     }
3273 }
3274
3275 #-> sub CPAN::Distribution::dir ;
3276 sub dir {
3277     shift->{'build_dir'};
3278 }
3279
3280 package CPAN::Bundle;
3281
3282 #-> sub CPAN::Bundle::as_string ;
3283 sub as_string {
3284     my($self) = @_;
3285     $self->contains;
3286     $self->{INST_VERSION} = $self->inst_version;
3287     return $self->SUPER::as_string;
3288 }
3289
3290 #-> sub CPAN::Bundle::contains ;
3291 sub contains {
3292     my($self) = @_;
3293     my($parsefile) = $self->inst_file;
3294     my($id) = $self->id;
3295     $self->debug("parsefile[$parsefile]id[$id]") if $CPAN::DEBUG;
3296     unless ($parsefile) {
3297         # Try to get at it in the cpan directory
3298         $self->debug("no parsefile") if $CPAN::DEBUG;
3299         Carp::confess "I don't know a $id" unless $self->{CPAN_FILE};
3300         my $dist = $CPAN::META->instance('CPAN::Distribution',
3301                                          $self->{CPAN_FILE});
3302         $dist->get;
3303         $self->debug($dist->as_string) if $CPAN::DEBUG;
3304         my($todir) = $CPAN::Config->{'cpan_home'};
3305         my(@me,$from,$to,$me);
3306         @me = split /::/, $self->id;
3307         $me[-1] .= ".pm";
3308         $me = MM->catfile(@me);
3309         $from = $self->find_bundle_file($dist->{'build_dir'},$me);
3310         $to = MM->catfile($todir,$me);
3311         File::Path::mkpath(File::Basename::dirname($to));
3312         File::Copy::copy($from, $to)
3313             or Carp::confess("Couldn't copy $from to $to: $!");
3314         $parsefile = $to;
3315     }
3316     my @result;
3317     my $fh = FileHandle->new;
3318     local $/ = "\n";
3319     open($fh,$parsefile) or die "Could not open '$parsefile': $!";
3320     my $inpod = 0;
3321     $self->debug("parsefile[$parsefile]") if $CPAN::DEBUG;
3322     while (<$fh>) {
3323         $inpod = /^=(?!head1\s+CONTENTS)/ ? 0 :
3324             /^=head1\s+CONTENTS/ ? 1 : $inpod;
3325         next unless $inpod;
3326         next if /^=/;
3327         next if /^\s+$/;
3328         chomp;
3329         push @result, (split " ", $_, 2)[0];
3330     }
3331     close $fh;
3332     delete $self->{STATUS};
3333     $self->{CONTAINS} = join ", ", @result;
3334     $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
3335     @result;
3336 }
3337
3338 #-> sub CPAN::Bundle::find_bundle_file
3339 sub find_bundle_file {
3340     my($self,$where,$what) = @_;
3341     $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
3342     my $bu = MM->catfile($where,$what);
3343     return $bu if -f $bu;
3344     my $manifest = MM->catfile($where,"MANIFEST");
3345     unless (-f $manifest) {
3346         require ExtUtils::Manifest;
3347         my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
3348         my $cwd = CPAN->$getcwd();
3349         chdir $where;
3350         ExtUtils::Manifest::mkmanifest();
3351         chdir $cwd;
3352     }
3353     my $fh = FileHandle->new($manifest)
3354         or Carp::croak("Couldn't open $manifest: $!");
3355     local($/) = "\n";
3356     while (<$fh>) {
3357         next if /^\s*\#/;
3358         my($file) = /(\S+)/;
3359         if ($file =~ m|\Q$what\E$|) {
3360             $bu = $file;
3361             return MM->catfile($where,$bu);
3362         } elsif ($what =~ s|Bundle/||) { # retry if she managed to
3363                                          # have no Bundle directory
3364             if ($file =~ m|\Q$what\E$|) {
3365                 $bu = $file;
3366                 return MM->catfile($where,$bu);
3367             }
3368         }
3369     }
3370     Carp::croak("Couldn't find a Bundle file in $where");
3371 }
3372
3373 #-> sub CPAN::Bundle::inst_file ;
3374 sub inst_file {
3375     my($self) = @_;
3376     my($me,$inst_file);
3377     ($me = $self->id) =~ s/.*://;
3378 ##    my(@me,$inst_file);
3379 ##    @me = split /::/, $self->id;
3380 ##    $me[-1] .= ".pm";
3381     $inst_file = MM->catfile($CPAN::Config->{'cpan_home'},
3382                                       "Bundle", "$me.pm");
3383 ##                                    "Bundle", @me);
3384     return $self->{'INST_FILE'} = $inst_file if -f $inst_file;
3385 #    $inst_file =
3386     $self->SUPER::inst_file;
3387 #    return $self->{'INST_FILE'} = $inst_file if -f $inst_file;
3388 #    return $self->{'INST_FILE'}; # even if undefined?
3389 }
3390
3391 #-> sub CPAN::Bundle::rematein ;
3392 sub rematein {
3393     my($self,$meth) = @_;
3394     $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
3395     my($id) = $self->id;
3396     Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
3397         unless $self->inst_file || $self->{CPAN_FILE};
3398     my($s);
3399     for $s ($self->contains) {
3400         my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
3401             $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
3402         if ($type eq 'CPAN::Distribution') {
3403             $CPAN::Frontend->mywarn(qq{
3404 The Bundle }.$self->id.qq{ contains
3405 explicitly a file $s.
3406 });
3407             sleep 3;
3408         }
3409         $CPAN::META->instance($type,$s)->$meth();
3410     }
3411 }
3412
3413 #sub CPAN::Bundle::xs_file
3414 sub xs_file {
3415     # If a bundle contains another that contains an xs_file we have
3416     # here, we just don't bother I suppose
3417     return 0;
3418 }
3419
3420 #-> sub CPAN::Bundle::force ;
3421 sub force   { shift->rematein('force',@_); }
3422 #-> sub CPAN::Bundle::get ;
3423 sub get     { shift->rematein('get',@_); }
3424 #-> sub CPAN::Bundle::make ;
3425 sub make    { shift->rematein('make',@_); }
3426 #-> sub CPAN::Bundle::test ;
3427 sub test    { shift->rematein('test',@_); }
3428 #-> sub CPAN::Bundle::install ;
3429 sub install {
3430   my $self = shift;
3431   $self->rematein('install',@_);
3432   $CPAN::META->delete('CPAN::Queue',$self->id);
3433 }
3434 #-> sub CPAN::Bundle::clean ;
3435 sub clean   { shift->rematein('clean',@_); }
3436
3437 #-> sub CPAN::Bundle::readme ;
3438 sub readme  {
3439     my($self) = @_;
3440     my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
3441 No File found for bundle } . $self->id . qq{\n}), return;
3442     $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
3443     $CPAN::META->instance('CPAN::Distribution',$file)->readme;
3444 }
3445
3446 package CPAN::Module;
3447
3448 #-> sub CPAN::Module::as_glimpse ;
3449 sub as_glimpse {
3450     my($self) = @_;
3451     my(@m);
3452     my $class = ref($self);
3453     $class =~ s/^CPAN:://;
3454     push @m, sprintf("%-15s %-15s (%s)\n", $class, $self->{ID},
3455                      $self->cpan_file);
3456     join "", @m;
3457 }
3458
3459 #-> sub CPAN::Module::as_string ;
3460 sub as_string {
3461     my($self) = @_;
3462     my(@m);
3463     CPAN->debug($self) if $CPAN::DEBUG;
3464     my $class = ref($self);
3465     $class =~ s/^CPAN:://;
3466     local($^W) = 0;
3467     push @m, $class, " id = $self->{ID}\n";
3468     my $sprintf = "    %-12s %s\n";
3469     push @m, sprintf($sprintf, 'DESCRIPTION', $self->{description})
3470         if $self->{description};
3471     my $sprintf2 = "    %-12s %s (%s)\n";
3472     my($userid);
3473     if ($userid = $self->{'CPAN_USERID'} || $self->{'userid'}){
3474         my $author;
3475         if ($author = CPAN::Shell->expand('Author',$userid)) {
3476           my $email = "";
3477           my $m; # old perls
3478           if ($m = $author->email) {
3479             $email = " <$m>";
3480           }
3481           push @m, sprintf(
3482                            $sprintf2,
3483                            'CPAN_USERID',
3484                            $userid,
3485                            $author->fullname . $email
3486                           );
3487         }
3488     }
3489     push @m, sprintf($sprintf, 'CPAN_VERSION', $self->{CPAN_VERSION})
3490         if $self->{CPAN_VERSION};
3491     push @m, sprintf($sprintf, 'CPAN_FILE', $self->{CPAN_FILE})
3492         if $self->{CPAN_FILE};
3493     my $sprintf3 = "    %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
3494     my(%statd,%stats,%statl,%stati);
3495     @statd{qw,? i c a b R M S,} = qw,unknown idea
3496         pre-alpha alpha beta released mature standard,;
3497     @stats{qw,? m d u n,}       = qw,unknown mailing-list
3498         developer comp.lang.perl.* none,;
3499     @statl{qw,? p c + o,}       = qw,unknown perl C C++ other,;
3500     @stati{qw,? f r O,}         = qw,unknown functions
3501         references+ties object-oriented,;
3502     $statd{' '} = 'unknown';
3503     $stats{' '} = 'unknown';
3504     $statl{' '} = 'unknown';
3505     $stati{' '} = 'unknown';
3506     push @m, sprintf(
3507                      $sprintf3,
3508                      'DSLI_STATUS',
3509                      $self->{statd},
3510                      $self->{stats},
3511                      $self->{statl},
3512                      $self->{stati},
3513                      $statd{$self->{statd}},
3514                      $stats{$self->{stats}},
3515                      $statl{$self->{statl}},
3516                      $stati{$self->{stati}}
3517                     ) if $self->{statd};
3518     my $local_file = $self->inst_file;
3519     if ($local_file) {
3520       $self->{MANPAGE} ||= $self->manpage_headline($local_file);
3521     }
3522     my($item);
3523     for $item (qw/MANPAGE CONTAINS/) {
3524         push @m, sprintf($sprintf, $item, $self->{$item})
3525             if exists $self->{$item};
3526     }
3527     push @m, sprintf($sprintf, 'INST_FILE',
3528                      $local_file || "(not installed)");
3529     push @m, sprintf($sprintf, 'INST_VERSION',
3530                      $self->inst_version) if $local_file;
3531     join "", @m, "\n";
3532 }
3533
3534 sub manpage_headline {
3535   my($self,$local_file) = @_;
3536   my(@local_file) = $local_file;
3537   $local_file =~ s/\.pm$/.pod/;
3538   push @local_file, $local_file;
3539   my(@result,$locf);
3540   for $locf (@local_file) {
3541     next unless -f $locf;
3542     my $fh = FileHandle->new($locf)
3543         or $Carp::Frontend->mydie("Couldn't open $locf: $!");
3544     my $inpod = 0;
3545     local $/ = "\n";
3546     while (<$fh>) {
3547       $inpod = /^=(?!head1\s+NAME)/ ? 0 :
3548           /^=head1\s+NAME/ ? 1 : $inpod;
3549       next unless $inpod;
3550       next if /^=/;
3551       next if /^\s+$/;
3552       chomp;
3553       push @result, $_;
3554     }
3555     close $fh;
3556     last if @result;
3557   }
3558   join " ", @result;
3559 }
3560
3561 #-> sub CPAN::Module::cpan_file ;
3562 sub cpan_file    {
3563     my $self = shift;
3564     CPAN->debug($self->id) if $CPAN::DEBUG;
3565     unless (defined $self->{'CPAN_FILE'}) {
3566         CPAN::Index->reload;
3567     }
3568     if (exists $self->{'CPAN_FILE'} && defined $self->{'CPAN_FILE'}){
3569         return $self->{'CPAN_FILE'};
3570     } elsif (exists $self->{'userid'} && defined $self->{'userid'}) {
3571         my $fullname = $CPAN::META->instance(CPAN::Author,
3572                                       $self->{'userid'})->fullname;
3573         my $email = $CPAN::META->instance(CPAN::Author,
3574                                       $self->{'userid'})->email;
3575         unless (defined $fullname && defined $email) {
3576             return "Contact Author $self->{userid} (Try ``a $self->{userid}'')";
3577         }
3578         return "Contact Author $fullname <$email>";
3579     } else {
3580         return "N/A";
3581     }
3582 }
3583
3584 *name = \&cpan_file;
3585
3586 #-> sub CPAN::Module::cpan_version ;
3587 sub cpan_version {
3588     my $self = shift;
3589     $self->{'CPAN_VERSION'} = 'undef'
3590         unless defined $self->{'CPAN_VERSION'}; # I believe this is
3591                                                 # always a bug in the
3592                                                 # index and should be
3593                                                 # reported as such,
3594                                                 # but usually I find
3595                                                 # out such an error
3596                                                 # and do not want to
3597                                                 # provoke too many
3598                                                 # bugreports
3599     $self->{'CPAN_VERSION'};
3600 }
3601
3602 #-> sub CPAN::Module::force ;
3603 sub force {
3604     my($self) = @_;
3605     $self->{'force_update'}++;
3606 }
3607
3608 #-> sub CPAN::Module::rematein ;
3609 sub rematein {
3610     my($self,$meth) = @_;
3611     $self->debug($self->id) if $CPAN::DEBUG;
3612     my $cpan_file = $self->cpan_file;
3613     if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
3614       $CPAN::Frontend->mywarn(sprintf qq{
3615   The module %s isn\'t available on CPAN.
3616
3617   Either the module has not yet been uploaded to CPAN, or it is
3618   temporary unavailable. Please contact the author to find out
3619   more about the status. Try ``i %s''.
3620 },
3621                               $self->id,
3622                               $self->id,
3623                              );
3624       return;
3625     }
3626     my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
3627     $pack->called_for($self->id);
3628     $pack->force if exists $self->{'force_update'};
3629     $pack->$meth();
3630     delete $self->{'force_update'};
3631 }
3632
3633 #-> sub CPAN::Module::readme ;
3634 sub readme { shift->rematein('readme') }
3635 #-> sub CPAN::Module::look ;
3636 sub look { shift->rematein('look') }
3637 #-> sub CPAN::Module::get ;
3638 sub get    { shift->rematein('get',@_); }
3639 #-> sub CPAN::Module::make ;
3640 sub make   { shift->rematein('make') }
3641 #-> sub CPAN::Module::test ;
3642 sub test   { shift->rematein('test') }
3643 #-> sub CPAN::Module::install ;
3644 sub install {
3645     my($self) = @_;
3646     my($doit) = 0;
3647     my($latest) = $self->cpan_version;
3648     $latest ||= 0;
3649     my($inst_file) = $self->inst_file;
3650     my($have) = 0;
3651     if (defined $inst_file) {
3652         $have = $self->inst_version;
3653     }
3654     if (1){ # A block for scoping $^W, the if is just for the visual
3655             # appeal
3656         local($^W)=0;
3657         if ($inst_file
3658             &&
3659             $have >= $latest
3660             &&
3661             not exists $self->{'force_update'}
3662            ) {
3663             $CPAN::Frontend->myprint( $self->id. " is up to date.\n");
3664         } else {
3665             $doit = 1;
3666         }
3667     }
3668     $self->rematein('install') if $doit;
3669     $CPAN::META->delete('CPAN::Queue',$self->id);
3670 }
3671 #-> sub CPAN::Module::clean ;
3672 sub clean  { shift->rematein('clean') }
3673
3674 #-> sub CPAN::Module::inst_file ;
3675 sub inst_file {
3676     my($self) = @_;
3677     my($dir,@packpath);
3678     @packpath = split /::/, $self->{ID};
3679     $packpath[-1] .= ".pm";
3680     foreach $dir (@INC) {
3681         my $pmfile = MM->catfile($dir,@packpath);
3682         if (-f $pmfile){
3683             return $pmfile;
3684         }
3685     }
3686     return;
3687 }
3688
3689 #-> sub CPAN::Module::xs_file ;
3690 sub xs_file {
3691     my($self) = @_;
3692     my($dir,@packpath);
3693     @packpath = split /::/, $self->{ID};
3694     push @packpath, $packpath[-1];
3695     $packpath[-1] .= "." . $Config::Config{'dlext'};
3696     foreach $dir (@INC) {
3697         my $xsfile = MM->catfile($dir,'auto',@packpath);
3698         if (-f $xsfile){
3699             return $xsfile;
3700         }
3701     }
3702     return;
3703 }
3704
3705 #-> sub CPAN::Module::inst_version ;
3706 sub inst_version {
3707     my($self) = @_;
3708     my $parsefile = $self->inst_file or return;
3709     local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
3710     my $have = MM->parse_version($parsefile) || "undef";
3711     $have =~ s/\s+//g;
3712     $have;
3713 }
3714
3715 package CPAN::Tarzip;
3716
3717 sub gzip {
3718   my($class,$read,$write) = @_;
3719   if ($CPAN::META->has_inst("Compress::Zlib")) {
3720     my($buffer,$fhw);
3721     $fhw = FileHandle->new($read)
3722         or $CPAN::Frontend->mydie("Could not open $read: $!");
3723     my $gz = Compress::Zlib::gzopen($write, "wb")
3724         or $CPAN::Frontend->mydie("Cannot gzopen $write: $!\n");
3725     $gz->gzwrite($buffer)
3726         while read($fhw,$buffer,4096) > 0 ;
3727     $gz->gzclose() ;
3728     $fhw->close;
3729     return 1;
3730   } else {
3731     system("$CPAN::Config->{'gzip'} -c $read > $write")==0;
3732   }
3733 }
3734
3735 sub gunzip {
3736   my($class,$read,$write) = @_;
3737   if ($CPAN::META->has_inst("Compress::Zlib")) {
3738     my($buffer,$fhw);
3739     $fhw = FileHandle->new(">$write")
3740         or $CPAN::Frontend->mydie("Could not open >$write: $!");
3741     my $gz = Compress::Zlib::gzopen($read, "rb")
3742         or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
3743     $fhw->print($buffer)
3744         while $gz->gzread($buffer) > 0 ;
3745     $CPAN::Frontend->mydie("Error reading from $read: $!\n")
3746         if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
3747     $gz->gzclose() ;
3748     $fhw->close;
3749     return 1;
3750   } else {
3751     system("$CPAN::Config->{'gzip'} -dc $read > $write")==0;
3752   }
3753 }
3754
3755 sub gtest {
3756   my($class,$read) = @_;
3757   if ($CPAN::META->has_inst("Compress::Zlib")) {
3758     my($buffer);
3759     my $gz = Compress::Zlib::gzopen($read, "rb")
3760         or $CPAN::Frontend->mydie("Cannot open $read: $!\n");
3761     1 while $gz->gzread($buffer) > 0 ;
3762     $CPAN::Frontend->mydie("Error reading from $read: $!\n")
3763         if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
3764     $gz->gzclose() ;
3765     return 1;
3766   } else {
3767     return system("$CPAN::Config->{'gzip'} -dt $read")==0;
3768   }
3769 }
3770
3771 sub TIEHANDLE {
3772   my($class,$file) = @_;
3773   my $ret;
3774   $class->debug("file[$file]");
3775   if ($CPAN::META->has_inst("Compress::Zlib")) {
3776     my $gz = Compress::Zlib::gzopen($file,"rb") or
3777         die "Could not gzopen $file";
3778     $ret = bless {GZ => $gz}, $class;
3779   } else {
3780     my $pipe = "$CPAN::Config->{'gzip'} --decompress --stdout $file |";
3781     my $fh = FileHandle->new($pipe) or die "Could pipe[$pipe]: $!";
3782     binmode $fh;
3783     $ret = bless {FH => $fh}, $class;
3784   }
3785   $ret;
3786 }
3787
3788 sub READLINE {
3789   my($self) = @_;
3790   if (exists $self->{GZ}) {
3791     my $gz = $self->{GZ};
3792     my($line,$bytesread);
3793     $bytesread = $gz->gzreadline($line);
3794     return undef if $bytesread == 0;
3795     return $line;
3796   } else {
3797     my $fh = $self->{FH};
3798     return scalar <$fh>;
3799   }
3800 }
3801
3802 sub READ {
3803   my($self,$ref,$length,$offset) = @_;
3804   die "read with offset not implemented" if defined $offset;
3805   if (exists $self->{GZ}) {
3806     my $gz = $self->{GZ};
3807     my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
3808     return $byteread;
3809   } else {
3810     my $fh = $self->{FH};
3811     return read($fh,$$ref,$length);
3812   }
3813 }
3814
3815 sub DESTROY {
3816   my($self) = @_;
3817   if (exists $self->{GZ}) {
3818     my $gz = $self->{GZ};
3819     $gz->gzclose();
3820   } else {
3821     my $fh = $self->{FH};
3822     $fh->close;
3823   }
3824   undef $self;
3825 }
3826
3827 sub untar {
3828   my($class,$file) = @_;
3829   # had to disable, because version 0.07 seems to be buggy
3830   if (MM->maybe_command($CPAN::Config->{'gzip'})
3831       &&
3832       MM->maybe_command($CPAN::Config->{'tar'})) {
3833     my $system = "$CPAN::Config->{'gzip'} --decompress --stdout " .
3834         "$file | $CPAN::Config->{tar} xvf -";
3835     return system($system) == 0;
3836   } elsif ($CPAN::META->has_inst("Archive::Tar")
3837       &&
3838       $CPAN::META->has_inst("Compress::Zlib") ) {
3839     my $tar = Archive::Tar->new($file,1);
3840     $tar->extract($tar->list_files); # I'm pretty sure we have nothing
3841                                      # that isn't compressed
3842     return 1;
3843   } else {
3844     $CPAN::Frontend->mydie(qq{
3845 CPAN.pm needs either both external programs tar and gzip installed or
3846 both the modules Archive::Tar and Compress::Zlib. Neither prerequisite
3847 is available. Can\'t continue.
3848 });
3849   }
3850 }
3851
3852 package CPAN;
3853
3854 1;
3855
3856 __END__
3857
3858 =head1 NAME
3859
3860 CPAN - query, download and build perl modules from CPAN sites
3861
3862 =head1 SYNOPSIS
3863
3864 Interactive mode:
3865
3866   perl -MCPAN -e shell;
3867
3868 Batch mode:
3869
3870   use CPAN;
3871
3872   autobundle, clean, install, make, recompile, test
3873
3874 =head1 DESCRIPTION
3875
3876 The CPAN module is designed to automate the make and install of perl
3877 modules and extensions. It includes some searching capabilities and
3878 knows how to use Net::FTP or LWP (or lynx or an external ftp client)
3879 to fetch the raw data from the net.
3880
3881 Modules are fetched from one or more of the mirrored CPAN
3882 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
3883 directory.
3884
3885 The CPAN module also supports the concept of named and versioned
3886 'bundles' of modules. Bundles simplify the handling of sets of
3887 related modules. See BUNDLES below.
3888
3889 The package contains a session manager and a cache manager. There is
3890 no status retained between sessions. The session manager keeps track
3891 of what has been fetched, built and installed in the current
3892 session. The cache manager keeps track of the disk space occupied by
3893 the make processes and deletes excess space according to a simple FIFO
3894 mechanism.
3895
3896 All methods provided are accessible in a programmer style and in an
3897 interactive shell style.
3898
3899 =head2 Interactive Mode
3900
3901 The interactive mode is entered by running
3902
3903     perl -MCPAN -e shell
3904
3905 which puts you into a readline interface. You will have the most fun if
3906 you install Term::ReadKey and Term::ReadLine to enjoy both history and
3907 command completion.
3908
3909 Once you are on the command line, type 'h' and the rest should be
3910 self-explanatory.
3911
3912 The most common uses of the interactive modes are
3913
3914 =over 2
3915
3916 =item Searching for authors, bundles, distribution files and modules
3917
3918 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
3919 for each of the four categories and another, C<i> for any of the
3920 mentioned four. Each of the four entities is implemented as a class
3921 with slightly differing methods for displaying an object.
3922
3923 Arguments you pass to these commands are either strings exactly matching
3924 the identification string of an object or regular expressions that are
3925 then matched case-insensitively against various attributes of the
3926 objects. The parser recognizes a regular expression only if you
3927 enclose it between two slashes.
3928
3929 The principle is that the number of found objects influences how an
3930 item is displayed. If the search finds one item, the result is displayed
3931 as object-E<gt>as_string, but if we find more than one, we display
3932 each as object-E<gt>as_glimpse. E.g.
3933
3934     cpan> a ANDK
3935     Author id = ANDK
3936         EMAIL        a.koenig@franz.ww.TU-Berlin.DE
3937         FULLNAME     Andreas König
3938
3939
3940     cpan> a /andk/
3941     Author id = ANDK
3942         EMAIL        a.koenig@franz.ww.TU-Berlin.DE
3943         FULLNAME     Andreas König
3944
3945
3946     cpan> a /and.*rt/
3947     Author          ANDYD (Andy Dougherty)
3948     Author          MERLYN (Randal L. Schwartz)
3949
3950 =item make, test, install, clean  modules or distributions
3951
3952 These commands take any number of arguments and investigate what is
3953 necessary to perform the action. If the argument is a distribution
3954 file name (recognized by embedded slashes), it is processed. If it is a
3955 module, CPAN determines the distribution file in which this module is
3956 included and processes that.
3957
3958 Any C<make> or C<test> are run unconditionally. An
3959
3960   install <distribution_file>
3961
3962 also is run unconditionally. But for
3963
3964   install <module>
3965
3966 CPAN checks if an install is actually needed for it and prints
3967 I<module up to date> in the case that the distribution file containing
3968 the module doesnE<39>t need to be updated.
3969
3970 CPAN also keeps track of what it has done within the current session
3971 and doesnE<39>t try to build a package a second time regardless if it
3972 succeeded or not. The C<force> command takes as a first argument the
3973 method to invoke (currently: C<make>, C<test>, or C<install>) and executes the
3974 command from scratch.
3975
3976 Example:
3977
3978     cpan> install OpenGL
3979     OpenGL is up to date.
3980     cpan> force install OpenGL
3981     Running make
3982     OpenGL-0.4/
3983     OpenGL-0.4/COPYRIGHT
3984     [...]
3985
3986 A C<clean> command results in a
3987
3988   make clean
3989
3990 being executed within the distribution file's working directory.
3991
3992 =item readme, look module or distribution
3993
3994 These two commands take only one argument, be it a module or a
3995 distribution file. C<readme> unconditionally runs, displaying the
3996 README of the associated distribution file. C<Look> gets and
3997 untars (if not yet done) the distribution file, changes to the
3998 appropriate directory and opens a subshell process in that directory.
3999
4000 =item Signals
4001
4002 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
4003 in the cpan-shell it is intended that you can press C<^C> anytime and
4004 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
4005 to clean up and leave the shell loop. You can emulate the effect of a
4006 SIGTERM by sending two consecutive SIGINTs, which usually means by
4007 pressing C<^C> twice.
4008
4009 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
4010 SIGALRM is used during the run of the C<perl Makefile.PL> subprocess.
4011
4012 =back
4013
4014 =head2 CPAN::Shell
4015
4016 The commands that are available in the shell interface are methods in
4017 the package CPAN::Shell. If you enter the shell command, all your
4018 input is split by the Text::ParseWords::shellwords() routine which
4019 acts like most shells do. The first word is being interpreted as the
4020 method to be called and the rest of the words are treated as arguments
4021 to this method. Continuation lines are supported if a line ends with a
4022 literal backslash.
4023
4024 =head2 autobundle
4025
4026 C<autobundle> writes a bundle file into the
4027 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
4028 a list of all modules that are both available from CPAN and currently
4029 installed within @INC. The name of the bundle file is based on the
4030 current date and a counter.
4031
4032 =head2 recompile
4033
4034 recompile() is a very special command in that it takes no argument and
4035 runs the make/test/install cycle with brute force over all installed
4036 dynamically loadable extensions (aka XS modules) with 'force' in
4037 effect. The primary purpose of this command is to finish a network
4038 installation. Imagine, you have a common source tree for two different
4039 architectures. You decide to do a completely independent fresh
4040 installation. You start on one architecture with the help of a Bundle
4041 file produced earlier. CPAN installs the whole Bundle for you, but
4042 when you try to repeat the job on the second architecture, CPAN
4043 responds with a C<"Foo up to date"> message for all modules. So you
4044 invoke CPAN's recompile on the second architecture and youE<39>re done.
4045
4046 Another popular use for C<recompile> is to act as a rescue in case your
4047 perl breaks binary compatibility. If one of the modules that CPAN uses
4048 is in turn depending on binary compatibility (so you cannot run CPAN
4049 commands), then you should try the CPAN::Nox module for recovery.
4050
4051 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
4052
4053 Although it may be considered internal, the class hierarchy does matter
4054 for both users and programmer. CPAN.pm deals with above mentioned four
4055 classes, and all those classes share a set of methods. A classical
4056 single polymorphism is in effect. A metaclass object registers all
4057 objects of all kinds and indexes them with a string. The strings
4058 referencing objects have a separated namespace (well, not completely
4059 separated):
4060
4061          Namespace                         Class
4062
4063    words containing a "/" (slash)      Distribution
4064     words starting with Bundle::          Bundle
4065           everything else            Module or Author
4066
4067 Modules know their associated Distribution objects. They always refer
4068 to the most recent official release. Developers may mark their releases
4069 as unstable development versions (by inserting an underbar into the
4070 visible version number), so the really hottest and newest distribution
4071 file is not always the default.  If a module Foo circulates on CPAN in
4072 both version 1.23 and 1.23_90, CPAN.pm offers a convenient way to
4073 install version 1.23 by saying
4074
4075     install Foo
4076
4077 This would install the complete distribution file (say
4078 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
4079 like to install version 1.23_90, you need to know where the
4080 distribution file resides on CPAN relative to the authors/id/
4081 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
4082 so you would have to say
4083
4084     install BAR/Foo-1.23_90.tar.gz
4085
4086 The first example will be driven by an object of the class
4087 CPAN::Module, the second by an object of class CPAN::Distribution.
4088
4089 =head2 ProgrammerE<39>s interface
4090
4091 If you do not enter the shell, the available shell commands are both
4092 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
4093 functions in the calling package (C<install(...)>).
4094
4095 There's currently only one class that has a stable interface -
4096 CPAN::Shell. All commands that are available in the CPAN shell are
4097 methods of the class CPAN::Shell. Each of the commands that produce
4098 listings of modules (C<r>, C<autobundle>, C<u>) returns a list of the
4099 IDs of all modules within the list.
4100
4101 =over 2
4102
4103 =item expand($type,@things)
4104
4105 The IDs of all objects available within a program are strings that can
4106 be expanded to the corresponding real objects with the
4107 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
4108 list of CPAN::Module objects according to the C<@things> arguments
4109 given. In scalar context it only returns the first element of the
4110 list.
4111
4112 =item Programming Examples
4113
4114 This enables the programmer to do operations that combine
4115 functionalities that are available in the shell.
4116
4117     # install everything that is outdated on my disk:
4118     perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
4119
4120     # install my favorite programs if necessary:
4121     for $mod (qw(Net::FTP MD5 Data::Dumper)){
4122         my $obj = CPAN::Shell->expand('Module',$mod);
4123         $obj->install;
4124     }
4125
4126     # list all modules on my disk that have no VERSION number
4127     for $mod (CPAN::Shell->expand("Module","/./")){
4128         next unless $mod->inst_file;
4129         # MakeMaker convention for undefined $VERSION:
4130         next unless $mod->inst_version eq "undef";
4131         print "No VERSION in ", $mod->id, "\n";
4132     }
4133
4134 =back
4135
4136 =head2 Methods in the four
4137
4138 =head2 Cache Manager
4139
4140 Currently the cache manager only keeps track of the build directory
4141 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
4142 deletes complete directories below C<build_dir> as soon as the size of
4143 all directories there gets bigger than $CPAN::Config->{build_cache}
4144 (in MB). The contents of this cache may be used for later
4145 re-installations that you intend to do manually, but will never be
4146 trusted by CPAN itself. This is due to the fact that the user might
4147 use these directories for building modules on different architectures.
4148
4149 There is another directory ($CPAN::Config->{keep_source_where}) where
4150 the original distribution files are kept. This directory is not
4151 covered by the cache manager and must be controlled by the user. If
4152 you choose to have the same directory as build_dir and as
4153 keep_source_where directory, then your sources will be deleted with
4154 the same fifo mechanism.
4155
4156 =head2 Bundles
4157
4158 A bundle is just a perl module in the namespace Bundle:: that does not
4159 define any functions or methods. It usually only contains documentation.
4160
4161 It starts like a perl module with a package declaration and a $VERSION
4162 variable. After that the pod section looks like any other pod with the
4163 only difference being that I<one special pod section> exists starting with
4164 (verbatim):
4165
4166         =head1 CONTENTS
4167
4168 In this pod section each line obeys the format
4169
4170         Module_Name [Version_String] [- optional text]
4171
4172 The only required part is the first field, the name of a module
4173 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
4174 of the line is optional. The comment part is delimited by a dash just
4175 as in the man page header.
4176
4177 The distribution of a bundle should follow the same convention as
4178 other distributions.
4179
4180 Bundles are treated specially in the CPAN package. If you say 'install
4181 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
4182 the modules in the CONTENTS section of the pod. You can install your
4183 own Bundles locally by placing a conformant Bundle file somewhere into
4184 your @INC path. The autobundle() command which is available in the
4185 shell interface does that for you by including all currently installed
4186 modules in a snapshot bundle file.
4187
4188 =head2 Prerequisites
4189
4190 If you have a local mirror of CPAN and can access all files with
4191 "file:" URLs, then you only need a perl better than perl5.003 to run
4192 this module. Otherwise Net::FTP is strongly recommended. LWP may be
4193 required for non-UNIX systems or if your nearest CPAN site is
4194 associated with an URL that is not C<ftp:>.
4195
4196 If you have neither Net::FTP nor LWP, there is a fallback mechanism
4197 implemented for an external ftp command or for an external lynx
4198 command.
4199
4200 =head2 Finding packages and VERSION
4201
4202 This module presumes that all packages on CPAN
4203
4204 =over 2
4205
4206 =item *
4207
4208 declare their $VERSION variable in an easy to parse manner. This
4209 prerequisite can hardly be relaxed because it consumes far too much
4210 memory to load all packages into the running program just to determine
4211 the $VERSION variable. Currently all programs that are dealing with
4212 version use something like this
4213
4214     perl -MExtUtils::MakeMaker -le \
4215         'print MM->parse_version($ARGV[0])' filename
4216
4217 If you are author of a package and wonder if your $VERSION can be
4218 parsed, please try the above method.
4219
4220 =item *
4221
4222 come as compressed or gzipped tarfiles or as zip files and contain a
4223 Makefile.PL (well, we try to handle a bit more, but without much
4224 enthusiasm).
4225
4226 =back
4227
4228 =head2 Debugging
4229
4230 The debugging of this module is pretty difficult, because we have
4231 interferences of the software producing the indices on CPAN, of the
4232 mirroring process on CPAN, of packaging, of configuration, of
4233 synchronicity, and of bugs within CPAN.pm.
4234
4235 In interactive mode you can try "o debug" which will list options for
4236 debugging the various parts of the package. The output may not be very
4237 useful for you as it's just a by-product of my own testing, but if you
4238 have an idea which part of the package may have a bug, it's sometimes
4239 worth to give it a try and send me more specific output. You should
4240 know that "o debug" has built-in completion support.
4241
4242 =head2 Floppy, Zip, and all that Jazz
4243
4244 CPAN.pm works nicely without network too. If you maintain machines
4245 that are not networked at all, you should consider working with file:
4246 URLs. Of course, you have to collect your modules somewhere first. So
4247 you might use CPAN.pm to put together all you need on a networked
4248 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
4249 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
4250 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
4251 with this floppy.
4252
4253 =head1 CONFIGURATION
4254
4255 When the CPAN module is installed, a site wide configuration file is
4256 created as CPAN/Config.pm. The default values defined there can be
4257 overridden in another configuration file: CPAN/MyConfig.pm. You can
4258 store this file in $HOME/.cpan/CPAN/MyConfig.pm if you want, because
4259 $HOME/.cpan is added to the search path of the CPAN module before the
4260 use() or require() statements.
4261
4262 Currently the following keys in the hash reference $CPAN::Config are
4263 defined:
4264
4265   build_cache        size of cache for directories to build modules
4266   build_dir          locally accessible directory to build modules
4267   index_expire       after this many days refetch index files
4268   cpan_home          local directory reserved for this package
4269   gzip               location of external program gzip
4270   inactivity_timeout breaks interactive Makefile.PLs after this
4271                      many seconds inactivity. Set to 0 to never break.
4272   inhibit_startup_message
4273                      if true, does not print the startup message
4274   keep_source        keep the source in a local directory?
4275   keep_source_where  directory in which to keep the source (if we do)
4276   make               location of external make program
4277   make_arg           arguments that should always be passed to 'make'
4278   make_install_arg   same as make_arg for 'make install'
4279   makepl_arg         arguments passed to 'perl Makefile.PL'
4280   pager              location of external program more (or any pager)
4281   tar                location of external program tar
4282   unzip              location of external program unzip
4283   urllist            arrayref to nearby CPAN sites (or equivalent locations)
4284   wait_list          arrayref to a wait server to try (See CPAN::WAIT)
4285
4286 You can set and query each of these options interactively in the cpan
4287 shell with the command set defined within the C<o conf> command:
4288
4289 =over 2
4290
4291 =item o conf E<lt>scalar optionE<gt>
4292
4293 prints the current value of the I<scalar option>
4294
4295 =item o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>
4296
4297 Sets the value of the I<scalar option> to I<value>
4298
4299 =item o conf E<lt>list optionE<gt>
4300
4301 prints the current value of the I<list option> in MakeMaker's
4302 neatvalue format.
4303
4304 =item o conf E<lt>list optionE<gt> [shift|pop]
4305
4306 shifts or pops the array in the I<list option> variable
4307
4308 =item o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>
4309
4310 works like the corresponding perl commands.
4311
4312 =back
4313
4314 =head2 CD-ROM support
4315
4316 The C<urllist> parameter of the configuration table contains a list of
4317 URLs that are to be used for downloading. If the list contains any
4318 C<file> URLs, CPAN always tries to get files from there first. This
4319 feature is disabled for index files. So the recommendation for the
4320 owner of a CD-ROM with CPAN contents is: include your local, possibly
4321 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
4322
4323   o conf urllist push file://localhost/CDROM/CPAN
4324
4325 CPAN.pm will then fetch the index files from one of the CPAN sites
4326 that come at the beginning of urllist. It will later check for each
4327 module if there is a local copy of the most recent version.
4328
4329 =head1 SECURITY
4330
4331 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
4332 install foreign, unmasked, unsigned code on your machine. We compare
4333 to a checksum that comes from the net just as the distribution file
4334 itself. If somebody has managed to tamper with the distribution file,
4335 they may have as well tampered with the CHECKSUMS file. Future
4336 development will go towards strong authentification.
4337
4338 =head1 EXPORT
4339
4340 Most functions in package CPAN are exported per default. The reason
4341 for this is that the primary use is intended for the cpan shell or for
4342 oneliners.
4343
4344 =head1 BUGS
4345
4346 We should give coverage for _all_ of the CPAN and not just the PAUSE
4347 part, right? In this discussion CPAN and PAUSE have become equal --
4348 but they are not. PAUSE is authors/ and modules/. CPAN is PAUSE plus
4349 the clpa/, doc/, misc/, ports/, src/, scripts/.
4350
4351 Future development should be directed towards a better integration of
4352 the other parts.
4353
4354 If a Makefile.PL requires special customization of libraries, prompts
4355 the user for special input, etc. then you may find CPAN is not able to
4356 build the distribution. In that case, you should attempt the
4357 traditional method of building a Perl module package from a shell.
4358
4359 =head1 AUTHOR
4360
4361 Andreas König E<lt>a.koenig@mind.deE<gt>
4362
4363 =head1 SEE ALSO
4364
4365 perl(1), CPAN::Nox(3)
4366
4367 =cut
4368