lib/CPAN.pm

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