lib/CPAN.pm

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