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 ###     $version =~ s/^\+//;
2043
2044         # if it as a bundle, instatiate a bundle object
2045         my($bundle,$id,$userid);
2046
2047         if ($mod eq 'CPAN') {
2048             local($^W)= 0;
2049             if ($version > $CPAN::VERSION){
2050                 print qq{
2051   There\'s a new CPAN.pm version (v$version) available!
2052   You might want to try
2053     install CPAN
2054     reload cpan
2055   without quitting the current session. It should be a seemless upgrade
2056   while we are running...
2057 };
2058                 sleep 2;
2059                 print qq{\n};
2060             }
2061             last if $CPAN::Signal;
2062         } elsif ($mod =~ /^Bundle::(.*)/) {
2063             $bundle = $1;
2064         }
2065
2066         if ($bundle){
2067             $id =  $CPAN::META->instance('CPAN::Bundle',$mod);
2068 ###         $id->set('CPAN_VERSION' => $version, 'CPAN_FILE' => $dist);
2069 # This "next" makes us faster but if the job is running long, we ignore
2070 # rereads which is bad. So we have to be a bit slower again.
2071 #       } elsif ($CPAN::META->exists('CPAN::Module',$mod)) {
2072 #           next;
2073         } else {
2074             # instantiate a module object
2075             $id = $CPAN::META->instance('CPAN::Module',$mod);
2076 ###         $id->set('CPAN_VERSION' => $version, 'CPAN_FILE' => $dist)
2077 ###             if $id->cpan_version ne $version || $id->cpan_file ne $dist; # good speed in here
2078         }
2079
2080         if ($id->cpan_file ne $dist){
2081             # determine the author
2082             ($userid) = $dist =~ /([^\/]+)/;
2083             $id->set(
2084                      'CPAN_USERID' => $userid,
2085                      'CPAN_VERSION' => $version,
2086                      'CPAN_FILE' => $dist
2087                     );
2088         }
2089
2090         # instantiate a distribution object
2091         unless ($CPAN::META->exists('CPAN::Distribution',$dist)) {
2092             $CPAN::META->instance(
2093                                   'CPAN::Distribution' => $dist
2094                                  )->set(
2095                                         'CPAN_USERID' => $userid
2096                                        );
2097         }
2098
2099         return if $CPAN::Signal;
2100     }
2101     $fh->close;
2102     $? and Carp::croak "FAILED $pipe: exit status [$?]";
2103 }
2104
2105 #-> sub CPAN::Index::rd_modlist ;
2106 sub rd_modlist {
2107     my($cl,$index_target) = @_;
2108     my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target";
2109     print "Going to read $index_target\n";
2110     my $fh = FileHandle->new("$pipe|");
2111     my $eval;
2112     while (<$fh>) {
2113         if (/^Date:\s+(.*)/){
2114             return if $date_of_03 eq $1;
2115             ($date_of_03) = $1;
2116         }
2117         last if /^\s*$/;
2118     }
2119     local($/) = undef;
2120     $eval = <$fh>;
2121     $fh->close;
2122     $eval .= q{CPAN::Modulelist->data;};
2123     local($^W) = 0;
2124     my($comp) = Safe->new("CPAN::Safe1");
2125     my $ret = $comp->reval($eval);
2126     Carp::confess($@) if $@;
2127     return if $CPAN::Signal;
2128     for (keys %$ret) {
2129         my $obj = $CPAN::META->instance(CPAN::Module,$_);
2130         $obj->set(%{$ret->{$_}});
2131         return if $CPAN::Signal;
2132     }
2133 }
2134
2135 package CPAN::InfoObj;
2136
2137 #-> sub CPAN::InfoObj::new ;
2138 sub new { my $this = bless {}, shift; %$this = @_; $this }
2139
2140 #-> sub CPAN::InfoObj::set ;
2141 sub set {
2142     my($self,%att) = @_;
2143     my(%oldatt) = %$self;
2144     %$self = (%oldatt, %att);
2145 }
2146
2147 #-> sub CPAN::InfoObj::id ;
2148 sub id { shift->{'ID'} }
2149
2150 #-> sub CPAN::InfoObj::as_glimpse ;
2151 sub as_glimpse {
2152     my($self) = @_;
2153     my(@m);
2154     my $class = ref($self);
2155     $class =~ s/^CPAN:://;
2156     push @m, sprintf "%-15s %s\n", $class, $self->{ID};
2157     join "", @m;
2158 }
2159
2160 #-> sub CPAN::InfoObj::as_string ;
2161 sub as_string {
2162     my($self) = @_;
2163     my(@m);
2164     my $class = ref($self);
2165     $class =~ s/^CPAN:://;
2166     push @m, $class, " id = $self->{ID}\n";
2167     for (sort keys %$self) {
2168         next if $_ eq 'ID';
2169         my $extra = "";
2170         $_ eq "CPAN_USERID" and $extra = " (".$self->author.")";
2171         if (ref($self->{$_}) eq "ARRAY") { # Should we setup a language interface? XXX
2172             push @m, sprintf "    %-12s %s%s\n", $_, "@{$self->{$_}}", $extra;
2173         } else {
2174             push @m, sprintf "    %-12s %s%s\n", $_, $self->{$_}, $extra;
2175         }
2176     }
2177     join "", @m, "\n";
2178 }
2179
2180 #-> sub CPAN::InfoObj::author ;
2181 sub author {
2182     my($self) = @_;
2183     $CPAN::META->instance(CPAN::Author,$self->{CPAN_USERID})->fullname;
2184 }
2185
2186 package CPAN::Author;
2187
2188 #-> sub CPAN::Author::as_glimpse ;
2189 sub as_glimpse {
2190     my($self) = @_;
2191     my(@m);
2192     my $class = ref($self);
2193     $class =~ s/^CPAN:://;
2194     push @m, sprintf "%-15s %s (%s)\n", $class, $self->{ID}, $self->fullname;
2195     join "", @m;
2196 }
2197
2198 # Dead code, I would have liked to have,,, but it was never reached,,,
2199 #sub make {
2200 #    my($self) = @_;
2201 #    return "Don't be silly, you can't make $self->{FULLNAME} ;-)\n";
2202 #}
2203
2204 #-> sub CPAN::Author::fullname ;
2205 sub fullname { shift->{'FULLNAME'} }
2206 *name = \&fullname;
2207 #-> sub CPAN::Author::email ;
2208 sub email    { shift->{'EMAIL'} }
2209
2210 package CPAN::Distribution;
2211
2212 #-> sub CPAN::Distribution::called_for ;
2213 sub called_for {
2214     my($self,$id) = @_;
2215     $self->{'CALLED_FOR'} = $id if defined $id;
2216     return $self->{'CALLED_FOR'};
2217 }
2218
2219 #-> sub CPAN::Distribution::get ;
2220 sub get {
2221     my($self) = @_;
2222   EXCUSE: {
2223         my @e;
2224         exists $self->{'build_dir'} and push @e,
2225             "Unwrapped into directory $self->{'build_dir'}";
2226         print join "", map {"  $_\n"} @e and return if @e;
2227     }
2228     my($local_file);
2229     my($local_wanted) =
2230          CPAN->catfile(
2231                         $CPAN::Config->{keep_source_where},
2232                         "authors",
2233                         "id",
2234                         split("/",$self->{ID})
2235                        );
2236
2237     $self->debug("Doing localize") if $CPAN::DEBUG;
2238     $local_file = CPAN::FTP->localize("authors/id/$self->{ID}", $local_wanted);
2239     $self->{localfile} = $local_file;
2240     my $builddir = $CPAN::META->{cachemgr}->dir;
2241     $self->debug("doing chdir $builddir") if $CPAN::DEBUG;
2242     chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
2243     my $packagedir;
2244
2245     $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
2246     if ($CPAN::META->has_inst('MD5')) {
2247         $self->debug("MD5 is installed, verifying");
2248         $self->verifyMD5;
2249     } else {
2250         $self->debug("MD5 is NOT installed");
2251     }
2252     $self->debug("Removing tmp") if $CPAN::DEBUG;
2253     File::Path::rmtree("tmp");
2254     mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
2255     chdir "tmp";
2256     $self->debug("Changed directory to tmp") if $CPAN::DEBUG;
2257     if ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)$/i){
2258         $self->untar_me($local_file);
2259     } elsif ( $local_file =~ /\.zip$/i ) {
2260         $self->unzip_me($local_file);
2261     } elsif ( $local_file =~ /\.pm\.(gz|Z)$/) {
2262         $self->pm2dir_me($local_file);
2263     } else {
2264         $self->{archived} = "NO";
2265     }
2266     chdir "..";
2267     if ($self->{archived} ne 'NO') {
2268         chdir "tmp";
2269         # Let's check if the package has its own directory.
2270         my $dh = DirHandle->new(".") or Carp::croak("Couldn't opendir .: $!");
2271         my @readdir = grep $_ !~ /^\.\.?$/, $dh->read; ### MAC??
2272         $dh->close;
2273         my ($distdir,$packagedir);
2274         if (@readdir == 1 && -d $readdir[0]) {
2275             $distdir = $readdir[0];
2276             $packagedir = $CPAN::META->catdir($builddir,$distdir);
2277             -d $packagedir and print "Removing previously used $packagedir\n";
2278             File::Path::rmtree($packagedir);
2279             rename($distdir,$packagedir) or Carp::confess("Couldn't rename $distdir to $packagedir: $!");
2280         } else {
2281             my $pragmatic_dir = $self->{'CPAN_USERID'} . '000';
2282             $pragmatic_dir =~ s/\W_//g;
2283             $pragmatic_dir++ while -d "../$pragmatic_dir";
2284             $packagedir = $CPAN::META->catdir($builddir,$pragmatic_dir);
2285             File::Path::mkpath($packagedir);
2286             my($f);
2287             for $f (@readdir) { # is already without "." and ".."
2288                 my $to = $CPAN::META->catdir($packagedir,$f);
2289                 rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
2290             }
2291         }
2292         $self->{'build_dir'} = $packagedir;
2293         chdir "..";
2294
2295         $self->debug("Changed directory to .. (self is $self [".$self->as_string."])")
2296             if $CPAN::DEBUG;
2297         File::Path::rmtree("tmp");
2298         if ($CPAN::Config->{keep_source_where} =~ /^no/i ){
2299             print "Going to unlink $local_file\n";
2300             unlink $local_file or Carp::carp "Couldn't unlink $local_file";
2301         }
2302         my($makefilepl) = $CPAN::META->catfile($packagedir,"Makefile.PL");
2303         unless (-f $makefilepl) {
2304             my($configure) = $CPAN::META->catfile($packagedir,"Configure");
2305             if (-f $configure) {
2306                 # do we have anything to do?
2307                 $self->{'configure'} = $configure;
2308             } else {
2309                 my $fh = FileHandle->new(">$makefilepl")
2310                     or Carp::croak("Could not open >$makefilepl");
2311                 my $cf = $self->called_for || "unknown";
2312                 $fh->print(
2313 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
2314 # because there was no Makefile.PL supplied.
2315 # Autogenerated on: }.scalar localtime().qq{
2316
2317                     use ExtUtils::MakeMaker;
2318                     WriteMakefile(NAME => q[$cf]);
2319
2320 });
2321                 print qq{Package comes without Makefile.PL.\n}.
2322                     qq{  Writing one on our own (calling it $cf)\n};
2323             }
2324         }
2325     }
2326     return $self;
2327 }
2328
2329 sub untar_me {
2330     my($self,$local_file) = @_;
2331     $self->{archived} = "tar";
2332     my $system = "$CPAN::Config->{gzip} --decompress --stdout " .
2333         "$local_file | $CPAN::Config->{tar} xvf -";
2334     if (system($system)== 0) {
2335         $self->{unwrapped} = "YES";
2336     } else {
2337         $self->{unwrapped} = "NO";
2338     }
2339 }
2340
2341 sub unzip_me {
2342     my($self,$local_file) = @_;
2343     $self->{archived} = "zip";
2344     my $system = "$CPAN::Config->{unzip} $local_file";
2345     if (system($system) == 0) {
2346         $self->{unwrapped} = "YES";
2347     } else {
2348         $self->{unwrapped} = "NO";
2349     }
2350 }
2351
2352 sub pm2dir_me {
2353     my($self,$local_file) = @_;
2354     $self->{archived} = "pm";
2355     my $to = File::Basename::basename($local_file);
2356     $to =~ s/\.(gz|Z)$//;
2357     my $system = "$CPAN::Config->{gzip} --decompress --stdout $local_file > $to";
2358     if (system($system) == 0) {
2359         $self->{unwrapped} = "YES";
2360     } else {
2361         $self->{unwrapped} = "NO";
2362     }
2363 }
2364
2365 #-> sub CPAN::Distribution::new ;
2366 sub new {
2367     my($class,%att) = @_;
2368
2369     $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
2370
2371     my $this = { %att };
2372     return bless $this, $class;
2373 }
2374
2375 #-> sub CPAN::Distribution::look ;
2376 sub look {
2377     my($self) = @_;
2378     if (  $CPAN::Config->{'shell'} ) {
2379         print qq{
2380 Trying to open a subshell in the build directory...
2381 };
2382     } else {
2383         print qq{
2384 Your configuration does not define a value for subshells.
2385 Please define it with "o conf shell <your shell>"
2386 };
2387         return;
2388     }
2389     my $dist = $self->id;
2390     my $dir  = $self->dir or $self->get;
2391     $dir = $self->dir;
2392     my $getcwd;
2393     $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
2394     my $pwd  = CPAN->$getcwd();
2395     chdir($dir);
2396     print qq{Working directory is $dir.\n};
2397     system($CPAN::Config->{'shell'}) == 0 or die "Subprocess shell error";
2398     chdir($pwd);
2399 }
2400
2401 #-> sub CPAN::Distribution::readme ;
2402 sub readme {
2403     my($self) = @_;
2404     my($dist) = $self->id;
2405     my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
2406     $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
2407     my($local_file);
2408     my($local_wanted) =
2409          CPAN->catfile(
2410                         $CPAN::Config->{keep_source_where},
2411                         "authors",
2412                         "id",
2413                         split("/","$sans.readme"),
2414                        );
2415     $self->debug("Doing localize") if $CPAN::DEBUG;
2416     $local_file = CPAN::FTP->localize("authors/id/$sans.readme", $local_wanted);
2417     my $fh_pager = FileHandle->new;
2418     $fh_pager->open("|$CPAN::Config->{'pager'}")
2419         or die "Could not open pager $CPAN::Config->{'pager'}: $!";
2420     my $fh_readme = FileHandle->new;
2421     $fh_readme->open($local_file) or die "Could not open $local_file: $!";
2422     $fh_pager->print(<$fh_readme>);
2423 }
2424
2425 #-> sub CPAN::Distribution::verifyMD5 ;
2426 sub verifyMD5 {
2427     my($self) = @_;
2428   EXCUSE: {
2429         my @e;
2430         $self->{MD5_STATUS} ||= "";
2431         $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
2432         print join "", map {"  $_\n"} @e and return if @e;
2433     }
2434     my($lc_want,$lc_file,@local,$basename);
2435     @local = split("/",$self->{ID});
2436     pop @local;
2437     push @local, "CHECKSUMS";
2438     $lc_want =
2439         CPAN->catfile($CPAN::Config->{keep_source_where},
2440                       "authors", "id", @local);
2441     local($") = "/";
2442     if (
2443         -f $lc_want
2444         &&
2445         $self->MD5_check_file($lc_want)
2446        ) {
2447         return $self->{MD5_STATUS} = "OK";
2448     }
2449     $lc_file = CPAN::FTP->localize("authors/id/@local",
2450                                    $lc_want,'force>:-{');
2451     unless ($lc_file) {
2452         $local[-1] .= ".gz";
2453         $lc_file = CPAN::FTP->localize("authors/id/@local",
2454                                        "$lc_want.gz",'force>:-{');
2455         my @system = ($CPAN::Config->{gzip}, '--decompress', $lc_file);
2456         system(@system) == 0 or die "Could not uncompress $lc_file";
2457         $lc_file =~ s/\.gz$//;
2458     }
2459     $self->MD5_check_file($lc_file);
2460 }
2461
2462 #-> sub CPAN::Distribution::MD5_check_file ;
2463 sub MD5_check_file {
2464     my($self,$chk_file) = @_;
2465     my($cksum,$file,$basename);
2466     $file =  $self->{localfile};
2467     $basename = File::Basename::basename($file);
2468     my $fh = FileHandle->new;
2469     local($/);
2470     if (open $fh, $chk_file){
2471         my $eval = <$fh>;
2472         close $fh;
2473         my($comp) = Safe->new();
2474         $cksum = $comp->reval($eval);
2475         if ($@) {
2476             rename $chk_file, "$chk_file.bad";
2477             Carp::confess($@) if $@;
2478         }
2479     } else {
2480         Carp::carp "Could not open $chk_file for reading";
2481     }
2482     if ($cksum->{$basename}->{md5}) {
2483         $self->debug("Found checksum for $basename:" .
2484                      "$cksum->{$basename}->{md5}\n") if $CPAN::DEBUG;
2485         my $pipe = "$CPAN::Config->{gzip} --decompress ".
2486             "--stdout $file|";
2487         if (
2488             open($fh, $file) &&
2489             binmode $fh &&
2490             $self->eq_MD5($fh,$cksum->{$basename}->{md5})
2491             or
2492             open($fh, $pipe) &&
2493             binmode $fh  &&
2494             $self->eq_MD5($fh,$cksum->{$basename}->{'md5-ungz'})
2495            ){
2496             print "Checksum for $file ok\n";
2497             return $self->{MD5_STATUS} = "OK";
2498         } else {
2499             print qq{Checksum mismatch for distribution file. }.
2500                 qq{Please investigate.\n\n};
2501             print $self->as_string;
2502             print $CPAN::META->instance(
2503                                         'CPAN::Author',
2504                                         $self->{CPAN_USERID}
2505                                        )->as_string;
2506             my $wrap = qq{I\'d recommend removing $file. It seems to
2507 be a bogus file.  Maybe you have configured your \`urllist\' with a
2508 bad URL.  Please check this array with \`o conf urllist\', and
2509 retry.};
2510             print Text::Wrap::wrap("","",$wrap);
2511             print "\n\n";
2512             sleep 3;
2513             return;
2514         }
2515         close $fh if fileno($fh);
2516     } else {
2517         $self->{MD5_STATUS} ||= "";
2518         if ($self->{MD5_STATUS} eq "NIL") {
2519             print "\nNo md5 checksum for $basename in local $chk_file.";
2520             print "Removing $chk_file\n";
2521             unlink $chk_file or print "Could not unlink: $!";
2522             sleep 1;
2523         }
2524         $self->{MD5_STATUS} = "NIL";
2525         return;
2526     }
2527 }
2528
2529 #-> sub CPAN::Distribution::eq_MD5 ;
2530 sub eq_MD5 {
2531     my($self,$fh,$expectMD5) = @_;
2532     my $md5 = MD5->new;
2533     $md5->addfile($fh);
2534     my $hexdigest = $md5->hexdigest;
2535     $hexdigest eq $expectMD5;
2536 }
2537
2538 #-> sub CPAN::Distribution::force ;
2539 sub force {
2540     my($self) = @_;
2541     $self->{'force_update'}++;
2542     delete $self->{'MD5_STATUS'};
2543     delete $self->{'archived'};
2544     delete $self->{'build_dir'};
2545     delete $self->{'localfile'};
2546     delete $self->{'make'};
2547     delete $self->{'install'};
2548     delete $self->{'unwrapped'};
2549     delete $self->{'writemakefile'};
2550 }
2551
2552 #-> sub CPAN::Distribution::perl ;
2553 sub perl {
2554     my($self) = @_;
2555     my($perl) = MM->file_name_is_absolute($^X) ? $^X : "";
2556     my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
2557     my $pwd  = CPAN->$getcwd();
2558     my $candidate = $CPAN::META->catfile($pwd,$^X);
2559     $perl ||= $candidate if MM->maybe_command($candidate);
2560     unless ($perl) {
2561         my ($component,$perl_name);
2562       DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
2563             PATH_COMPONENT: foreach $component (MM->path(), $Config::Config{'binexp'}) {
2564                   next unless defined($component) && $component;
2565                   my($abs) = MM->catfile($component,$perl_name);
2566                   if (MM->maybe_command($abs)) {
2567                       $perl = $abs;
2568                       last DIST_PERLNAME;
2569                   }
2570               }
2571           }
2572     }
2573     $perl;
2574 }
2575
2576 #-> sub CPAN::Distribution::make ;
2577 sub make {
2578     my($self) = @_;
2579     $self->debug($self->id) if $CPAN::DEBUG;
2580     print "Running make\n";
2581     $self->get;
2582   EXCUSE: {
2583         my @e;
2584         $self->{archived} eq "NO" and push @e,
2585         "Is neither a tar nor a zip archive.";
2586
2587         $self->{unwrapped} eq "NO" and push @e,
2588         "had problems unarchiving. Please build manually";
2589
2590         exists $self->{writemakefile} &&
2591             $self->{writemakefile} eq "NO" and push @e,
2592             "Had some problem writing Makefile";
2593
2594         defined $self->{'make'} and push @e,
2595         "Has already been processed within this session";
2596
2597         print join "", map {"  $_\n"} @e and return if @e;
2598     }
2599     print "\n  CPAN.pm: Going to build ".$self->id."\n\n";
2600     my $builddir = $self->dir;
2601     chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
2602     $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
2603
2604     my $system;
2605     if ($self->{'configure'}) {
2606         $system = $self->{'configure'};
2607     } else {
2608         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
2609         my $switch = "";
2610 # This needs a handler that can be turned on or off:
2611 #       $switch = "-MExtUtils::MakeMaker ".
2612 #           "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
2613 #           if $] > 5.00310;
2614         $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
2615     }
2616     {
2617         local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
2618         my($ret,$pid);
2619         $@ = "";
2620         if ($CPAN::Config->{inactivity_timeout}) {
2621             eval {
2622                 alarm $CPAN::Config->{inactivity_timeout};
2623                 local $SIG{CHLD} = sub { wait };
2624                 if (defined($pid = fork)) {
2625                     if ($pid) { #parent
2626                         wait;
2627                     } else {    #child
2628                         exec $system;
2629                     }
2630                 } else {
2631                     print "Cannot fork: $!";
2632                     return;
2633                 }
2634             };
2635             alarm 0;
2636             if ($@){
2637                 kill 9, $pid;
2638                 waitpid $pid, 0;
2639                 print $@;
2640                 $self->{writemakefile} = "NO - $@";
2641                 $@ = "";
2642                 return;
2643             }
2644         } else {
2645             $ret = system($system);
2646             if ($ret != 0) {
2647                 $self->{writemakefile} = "NO";
2648                 return;
2649             }
2650         }
2651     }
2652     $self->{writemakefile} = "YES";
2653     return if $CPAN::Signal;
2654     $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
2655     if (system($system) == 0) {
2656          print "  $system -- OK\n";
2657          $self->{'make'} = "YES";
2658     } else {
2659          $self->{writemakefile} = "YES";
2660          $self->{'make'} = "NO";
2661          print "  $system -- NOT OK\n";
2662     }
2663 }
2664
2665 #-> sub CPAN::Distribution::test ;
2666 sub test {
2667     my($self) = @_;
2668     $self->make;
2669     return if $CPAN::Signal;
2670     print "Running make test\n";
2671   EXCUSE: {
2672         my @e;
2673         exists $self->{'make'} or push @e,
2674         "Make had some problems, maybe interrupted? Won't test";
2675
2676         exists $self->{'make'} and
2677             $self->{'make'} eq 'NO' and
2678                 push @e, "Oops, make had returned bad status";
2679
2680         exists $self->{'build_dir'} or push @e, "Has no own directory";
2681         print join "", map {"  $_\n"} @e and return if @e;
2682     }
2683     chdir $self->{'build_dir'} or Carp::croak("Couldn't chdir to $self->{'build_dir'}");
2684     $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
2685     my $system = join " ", $CPAN::Config->{'make'}, "test";
2686     if (system($system) == 0) {
2687          print "  $system -- OK\n";
2688          $self->{'make_test'} = "YES";
2689     } else {
2690          $self->{'make_test'} = "NO";
2691          print "  $system -- NOT OK\n";
2692     }
2693 }
2694
2695 #-> sub CPAN::Distribution::clean ;
2696 sub clean {
2697     my($self) = @_;
2698     print "Running make clean\n";
2699   EXCUSE: {
2700         my @e;
2701         exists $self->{'build_dir'} or push @e, "Has no own directory";
2702         print join "", map {"  $_\n"} @e and return if @e;
2703     }
2704     chdir $self->{'build_dir'} or Carp::croak("Couldn't chdir to $self->{'build_dir'}");
2705     $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
2706     my $system = join " ", $CPAN::Config->{'make'}, "clean";
2707     if (system($system) == 0) {
2708         print "  $system -- OK\n";
2709         $self->force;
2710     } else {
2711         # Hmmm, what to do if make clean failed?
2712     }
2713 }
2714
2715 #-> sub CPAN::Distribution::install ;
2716 sub install {
2717     my($self) = @_;
2718     $self->test;
2719     return if $CPAN::Signal;
2720     print "Running make install\n";
2721   EXCUSE: {
2722         my @e;
2723         exists $self->{'build_dir'} or push @e, "Has no own directory";
2724
2725         exists $self->{'make'} or push @e,
2726         "Make had some problems, maybe interrupted? Won't install";
2727
2728         exists $self->{'make'} and
2729             $self->{'make'} eq 'NO' and
2730                 push @e, "Oops, make had returned bad status";
2731
2732         push @e, "make test had returned bad status, won't install without force"
2733             if exists $self->{'make_test'} and
2734             $self->{'make_test'} eq 'NO' and
2735             ! $self->{'force_update'};
2736
2737         exists $self->{'install'} and push @e,
2738         $self->{'install'} eq "YES" ?
2739             "Already done" : "Already tried without success";
2740
2741         print join "", map {"  $_\n"} @e and return if @e;
2742     }
2743     chdir $self->{'build_dir'} or Carp::croak("Couldn't chdir to $self->{'build_dir'}");
2744     $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
2745     my $system = join " ", $CPAN::Config->{'make'}, "install", $CPAN::Config->{make_install_arg};
2746     my($pipe) = FileHandle->new("$system 2>&1 |");
2747     my($makeout) = "";
2748     while (<$pipe>){
2749         print;
2750         $makeout .= $_;
2751     }
2752     $pipe->close;
2753     if ($?==0) {
2754          print "  $system -- OK\n";
2755          $self->{'install'} = "YES";
2756     } else {
2757          $self->{'install'} = "NO";
2758          print "  $system -- NOT OK\n";
2759          if ($makeout =~ /permission/s && $> > 0) {
2760              print "    You may have to su to root to install the package\n";
2761          }
2762     }
2763 }
2764
2765 #-> sub CPAN::Distribution::dir ;
2766 sub dir {
2767     shift->{'build_dir'};
2768 }
2769
2770 package CPAN::Bundle;
2771
2772 #-> sub CPAN::Bundle::as_string ;
2773 sub as_string {
2774     my($self) = @_;
2775     $self->contains;
2776     $self->{INST_VERSION} = $self->inst_version;
2777     return $self->SUPER::as_string;
2778 }
2779
2780 #-> sub CPAN::Bundle::contains ;
2781 sub contains {
2782     my($self) = @_;
2783     my($parsefile) = $self->inst_file;
2784     unless ($parsefile) {
2785         # Try to get at it in the cpan directory
2786         $self->debug("no parsefile") if $CPAN::DEBUG;
2787         my $dist = $CPAN::META->instance('CPAN::Distribution',$self->{'CPAN_FILE'});
2788         $dist->get;
2789         $self->debug($dist->as_string) if $CPAN::DEBUG;
2790         my($todir) = $CPAN::META->catdir($CPAN::Config->{'cpan_home'},"Bundle");
2791         File::Path::mkpath($todir);
2792         my($me,$from,$to);
2793         ($me = $self->id) =~ s/.*://;
2794         $from = $self->find_bundle_file($dist->{'build_dir'},"$me.pm");
2795         $to = $CPAN::META->catfile($todir,"$me.pm");
2796         File::Copy::copy($from, $to) or Carp::confess("Couldn't copy $from to $to: $!");
2797         $parsefile = $to;
2798     }
2799     my @result;
2800     my $fh = FileHandle->new;
2801     local $/ = "\n";
2802     open($fh,$parsefile) or die "Could not open '$parsefile': $!";
2803     my $inpod = 0;
2804     $self->debug("parsefile[$parsefile]") if $CPAN::DEBUG;
2805     while (<$fh>) {
2806         $inpod = /^=(?!head1\s+CONTENTS)/ ? 0 : /^=head1\s+CONTENTS/ ? 1 : $inpod;
2807         next unless $inpod;
2808         next if /^=/;
2809         next if /^\s+$/;
2810         chomp;
2811         push @result, (split " ", $_, 2)[0];
2812     }
2813     close $fh;
2814     delete $self->{STATUS};
2815     $self->{CONTAINS} = join ", ", @result;
2816     $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
2817     @result;
2818 }
2819
2820 #-> sub CPAN::Bundle::find_bundle_file
2821 sub find_bundle_file {
2822     my($self,$where,$what) = @_;
2823     my $bu = $CPAN::META->catfile($where,$what);
2824     return $bu if -f $bu;
2825     my $manifest = $CPAN::META->catfile($where,"MANIFEST");
2826     unless (-f $manifest) {
2827         require ExtUtils::Manifest;
2828         my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
2829         my $cwd = CPAN->$getcwd();
2830         chdir $where;
2831         ExtUtils::Manifest::mkmanifest();
2832         chdir $cwd;
2833     }
2834     my $fh = FileHandle->new($manifest) or Carp::croak("Couldn't open $manifest: $!");
2835     local($/) = "\n";
2836     while (<$fh>) {
2837         next if /^\s*\#/;
2838         my($file) = /(\S+)/;
2839         if ($file =~ m|Bundle/$what$|) {
2840             $bu = $file;
2841             return $CPAN::META->catfile($where,$bu);
2842         }
2843     }
2844     Carp::croak("Could't find a Bundle file in $where");
2845 }
2846
2847 #-> sub CPAN::Bundle::inst_file ;
2848 sub inst_file {
2849     my($self) = @_;
2850     my($me,$inst_file);
2851     ($me = $self->id) =~ s/.*://;
2852     $inst_file = $CPAN::META->catfile($CPAN::Config->{'cpan_home'},"Bundle", "$me.pm");
2853     return $self->{'INST_FILE'} = $inst_file if -f $inst_file;
2854 #    $inst_file =
2855     $self->SUPER::inst_file;
2856 #    return $self->{'INST_FILE'} = $inst_file if -f $inst_file;
2857 #    return $self->{'INST_FILE'}; # even if undefined?
2858 }
2859
2860 #-> sub CPAN::Bundle::rematein ;
2861 sub rematein {
2862     my($self,$meth) = @_;
2863     $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
2864     my($s);
2865     for $s ($self->contains) {
2866         my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
2867             $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
2868         if ($type eq 'CPAN::Distribution') {
2869             warn qq{
2870 The Bundle }.$self->id.qq{ contains
2871 explicitly a file $s.
2872 };
2873             sleep 3;
2874         }
2875         $CPAN::META->instance($type,$s)->$meth();
2876     }
2877 }
2878
2879 #sub CPAN::Bundle::xs_file
2880 sub xs_file {
2881     # If a bundle contains another that contains an xs_file we have
2882     # here, we just don't bother I suppose
2883     return 0;
2884 }
2885
2886 #-> sub CPAN::Bundle::force ;
2887 sub force   { shift->rematein('force',@_); }
2888 #-> sub CPAN::Bundle::get ;
2889 sub get     { shift->rematein('get',@_); }
2890 #-> sub CPAN::Bundle::make ;
2891 sub make    { shift->rematein('make',@_); }
2892 #-> sub CPAN::Bundle::test ;
2893 sub test    { shift->rematein('test',@_); }
2894 #-> sub CPAN::Bundle::install ;
2895 sub install { shift->rematein('install',@_); }
2896 #-> sub CPAN::Bundle::clean ;
2897 sub clean   { shift->rematein('clean',@_); }
2898
2899 #-> sub CPAN::Bundle::readme ;
2900 sub readme  {
2901     my($self) = @_;
2902     my($file) = $self->cpan_file or print("No File found for bundle ", $self->id, "\n"), return;
2903     $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
2904     $CPAN::META->instance('CPAN::Distribution',$file)->readme;
2905 }
2906
2907 package CPAN::Module;
2908
2909 #-> sub CPAN::Module::as_glimpse ;
2910 sub as_glimpse {
2911     my($self) = @_;
2912     my(@m);
2913     my $class = ref($self);
2914     $class =~ s/^CPAN:://;
2915     push @m, sprintf "%-15s %-15s (%s)\n", $class, $self->{ID}, $self->cpan_file;
2916     join "", @m;
2917 }
2918
2919 #-> sub CPAN::Module::as_string ;
2920 sub as_string {
2921     my($self) = @_;
2922     my(@m);
2923     CPAN->debug($self) if $CPAN::DEBUG;
2924     my $class = ref($self);
2925     $class =~ s/^CPAN:://;
2926     local($^W) = 0;
2927     push @m, $class, " id = $self->{ID}\n";
2928     my $sprintf = "    %-12s %s\n";
2929     push @m, sprintf $sprintf, 'DESCRIPTION', $self->{description} if $self->{description};
2930     my $sprintf2 = "    %-12s %s (%s)\n";
2931     my($userid);
2932     if ($userid = $self->{'CPAN_USERID'} || $self->{'userid'}){
2933         push @m, sprintf(
2934                          $sprintf2,
2935                          'CPAN_USERID',
2936                          $userid,
2937                          CPAN::Shell->expand('Author',$userid)->fullname
2938                         )
2939     }
2940     push @m, sprintf $sprintf, 'CPAN_VERSION', $self->{CPAN_VERSION} if $self->{CPAN_VERSION};
2941     push @m, sprintf $sprintf, 'CPAN_FILE', $self->{CPAN_FILE} if $self->{CPAN_FILE};
2942     my $sprintf3 = "    %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
2943     my(%statd,%stats,%statl,%stati);
2944     @statd{qw,? i c a b R M S,} = qw,unknown idea pre-alpha alpha beta released mature standard,;
2945     @stats{qw,? m d u n,}       = qw,unknown mailing-list developer comp.lang.perl.* none,;
2946     @statl{qw,? p c + o,}       = qw,unknown perl C C++ other,;
2947     @stati{qw,? f r O,}         = qw,unknown functions references+ties object-oriented,;
2948     $statd{' '} = 'unknown';
2949     $stats{' '} = 'unknown';
2950     $statl{' '} = 'unknown';
2951     $stati{' '} = 'unknown';
2952     push @m, sprintf(
2953                      $sprintf3,
2954                      'DSLI_STATUS',
2955                      $self->{statd},
2956                      $self->{stats},
2957                      $self->{statl},
2958                      $self->{stati},
2959                      $statd{$self->{statd}},
2960                      $stats{$self->{stats}},
2961                      $statl{$self->{statl}},
2962                      $stati{$self->{stati}}
2963                     ) if $self->{statd};
2964     my $local_file = $self->inst_file;
2965     if ($local_file && ! exists $self->{MANPAGE}) {
2966         my $fh = FileHandle->new($local_file) or Carp::croak("Couldn't open $local_file: $!");
2967         my $inpod = 0;
2968         my(@result);
2969         local $/ = "\n";
2970         while (<$fh>) {
2971             $inpod = /^=(?!head1\s+NAME)/ ? 0 : /^=head1\s+NAME/ ? 1 : $inpod;
2972             next unless $inpod;
2973             next if /^=/;
2974             next if /^\s+$/;
2975             chomp;
2976             push @result, $_;
2977         }
2978         close $fh;
2979         $self->{MANPAGE} = join " ", @result;
2980     }
2981     my($item);
2982     for $item (qw/MANPAGE CONTAINS/) {
2983         push @m, sprintf $sprintf, $item, $self->{$item} if exists $self->{$item};
2984     }
2985     push @m, sprintf $sprintf, 'INST_FILE', $local_file || "(not installed)";
2986     push @m, sprintf $sprintf, 'INST_VERSION', $self->inst_version if $local_file;
2987     join "", @m, "\n";
2988 }
2989
2990 #-> sub CPAN::Module::cpan_file ;
2991 sub cpan_file    {
2992     my $self = shift;
2993     CPAN->debug($self->id) if $CPAN::DEBUG;
2994     unless (defined $self->{'CPAN_FILE'}) {
2995         CPAN::Index->reload;
2996     }
2997     if (defined $self->{'CPAN_FILE'}){
2998         return $self->{'CPAN_FILE'};
2999     } elsif (defined $self->{'userid'}) {
3000         return "Contact Author ".$self->{'userid'}."=".$CPAN::META->instance(CPAN::Author,$self->{'userid'})->fullname
3001     } else {
3002         return "N/A";
3003     }
3004 }
3005
3006 *name = \&cpan_file;
3007
3008 #-> sub CPAN::Module::cpan_version ;
3009 sub cpan_version { shift->{'CPAN_VERSION'} }
3010
3011 #-> sub CPAN::Module::force ;
3012 sub force {
3013     my($self) = @_;
3014     $self->{'force_update'}++;
3015 }
3016
3017 #-> sub CPAN::Module::rematein ;
3018 sub rematein {
3019     my($self,$meth) = @_;
3020     $self->debug($self->id) if $CPAN::DEBUG;
3021     my $cpan_file = $self->cpan_file;
3022     return if $cpan_file eq "N/A";
3023     return if $cpan_file =~ /^Contact Author/;
3024     my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
3025     $pack->called_for($self->id);
3026     $pack->force if exists $self->{'force_update'};
3027     $pack->$meth();
3028     delete $self->{'force_update'};
3029 }
3030
3031 #-> sub CPAN::Module::readme ;
3032 sub readme { shift->rematein('readme') }
3033 #-> sub CPAN::Module::look ;
3034 sub look { shift->rematein('look') }
3035 #-> sub CPAN::Module::get ;
3036 sub get    { shift->rematein('get',@_); }
3037 #-> sub CPAN::Module::make ;
3038 sub make   { shift->rematein('make') }
3039 #-> sub CPAN::Module::test ;
3040 sub test   { shift->rematein('test') }
3041 #-> sub CPAN::Module::install ;
3042 sub install {
3043     my($self) = @_;
3044     my($doit) = 0;
3045     my($latest) = $self->cpan_version;
3046     $latest ||= 0;
3047     my($inst_file) = $self->inst_file;
3048     my($have) = 0;
3049     if (defined $inst_file) {
3050         $have = $self->inst_version;
3051     }
3052     if (1){ # A block for scoping $^W, the if is just for the visual
3053             # appeal
3054         local($^W)=0;
3055         if ($inst_file && $have >= $latest && not exists $self->{'force_update'}) {
3056             print $self->id, " is up to date.\n";
3057         } else {
3058             $doit = 1;
3059         }
3060     }
3061     $self->rematein('install') if $doit;
3062 }
3063 #-> sub CPAN::Module::clean ;
3064 sub clean  { shift->rematein('clean') }
3065
3066 #-> sub CPAN::Module::inst_file ;
3067 sub inst_file {
3068     my($self) = @_;
3069     my($dir,@packpath);
3070     @packpath = split /::/, $self->{ID};
3071     $packpath[-1] .= ".pm";
3072     foreach $dir (@INC) {
3073         my $pmfile = CPAN->catfile($dir,@packpath);
3074         if (-f $pmfile){
3075             return $pmfile;
3076         }
3077     }
3078     return;
3079 }
3080
3081 #-> sub CPAN::Module::xs_file ;
3082 sub xs_file {
3083     my($self) = @_;
3084     my($dir,@packpath);
3085     @packpath = split /::/, $self->{ID};
3086     push @packpath, $packpath[-1];
3087     $packpath[-1] .= "." . $Config::Config{'dlext'};
3088     foreach $dir (@INC) {
3089         my $xsfile = CPAN->catfile($dir,'auto',@packpath);
3090         if (-f $xsfile){
3091             return $xsfile;
3092         }
3093     }
3094     return;
3095 }
3096
3097 #-> sub CPAN::Module::inst_version ;
3098 sub inst_version {
3099     my($self) = @_;
3100     my $parsefile = $self->inst_file or return 0;
3101     local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
3102     my $have = MM->parse_version($parsefile);
3103     $have ||= 0;
3104     $have =~ s/\s+//g;
3105     $have ||= 0;
3106     $have;
3107 }
3108
3109 package CPAN;
3110
3111 1;
3112
3113 __END__
3114
3115 =head1 NAME
3116
3117 CPAN - query, download and build perl modules from CPAN sites
3118
3119 =head1 SYNOPSIS
3120
3121 Interactive mode:
3122
3123   perl -MCPAN -e shell;
3124
3125 Batch mode:
3126
3127   use CPAN;
3128
3129   autobundle, clean, install, make, recompile, test
3130
3131 =head1 DESCRIPTION
3132
3133 The CPAN module is designed to automate the make and install of perl
3134 modules and extensions. It includes some searching capabilities and
3135 knows how to use Net::FTP or LWP (or lynx or an external ftp client)
3136 to fetch the raw data from the net.
3137
3138 Modules are fetched from one or more of the mirrored CPAN
3139 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
3140 directory.
3141
3142 The CPAN module also supports the concept of named and versioned
3143 'bundles' of modules. Bundles simplify the handling of sets of
3144 related modules. See BUNDLES below.
3145
3146 The package contains a session manager and a cache manager. There is
3147 no status retained between sessions. The session manager keeps track
3148 of what has been fetched, built and installed in the current
3149 session. The cache manager keeps track of the disk space occupied by
3150 the make processes and deletes excess space according to a simple FIFO
3151 mechanism.
3152
3153 All methods provided are accessible in a programmer style and in an
3154 interactive shell style.
3155
3156 =head2 Interactive Mode
3157
3158 The interactive mode is entered by running
3159
3160     perl -MCPAN -e shell
3161
3162 which puts you into a readline interface. You will have most fun if
3163 you install Term::ReadKey and Term::ReadLine to enjoy both history and
3164 completion.
3165
3166 Once you are on the command line, type 'h' and the rest should be
3167 self-explanatory.
3168
3169 The most common uses of the interactive modes are
3170
3171 =over 2
3172
3173 =item Searching for authors, bundles, distribution files and modules
3174
3175 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
3176 for each of the four categories and another, C<i> for any of the
3177 mentioned four. Each of the four entities is implemented as a class
3178 with slightly differing methods for displaying an object.
3179
3180 Arguments you pass to these commands are either strings matching exact
3181 the identification string of an object or regular expressions that are
3182 then matched case-insensitively against various attributes of the
3183 objects. The parser recognizes a regualar expression only if you
3184 enclose it between two slashes.
3185
3186 The principle is that the number of found objects influences how an
3187 item is displayed. If the search finds one item, we display the result
3188 of object-E<gt>as_string, but if we find more than one, we display
3189 each as object-E<gt>as_glimpse. E.g.
3190
3191     cpan> a ANDK
3192     Author id = ANDK
3193         EMAIL        a.koenig@franz.ww.TU-Berlin.DE
3194         FULLNAME     Andreas König
3195
3196
3197     cpan> a /andk/
3198     Author id = ANDK
3199         EMAIL        a.koenig@franz.ww.TU-Berlin.DE
3200         FULLNAME     Andreas König
3201
3202
3203     cpan> a /and.*rt/
3204     Author          ANDYD (Andy Dougherty)
3205     Author          MERLYN (Randal L. Schwartz)
3206
3207 =item make, test, install, clean  modules or distributions
3208
3209 These commands do indeed exist just as written above. Each of them
3210 takes any number of arguments and investigates for each what it might
3211 be. Is it a distribution file (recognized by embedded slashes), this
3212 file is being processed. Is it a module, CPAN determines the
3213 distribution file where this module is included and processes that.
3214
3215 Any C<make>, C<test>, and C<readme> are run unconditionally. A
3216
3217   install <distribution_file>
3218
3219 also is run unconditionally.  But for
3220
3221   install <module>
3222
3223 CPAN checks if an install is actually needed for it and prints
3224 I<Foo up to date> in case the module doesnE<39>t need to be updated.
3225
3226 CPAN also keeps track of what it has done within the current session
3227 and doesnE<39>t try to build a package a second time regardless if it
3228 succeeded or not. The C<force > command takes as first argument the
3229 method to invoke (currently: make, test, or install) and executes the
3230 command from scratch.
3231
3232 Example:
3233
3234     cpan> install OpenGL
3235     OpenGL is up to date.
3236     cpan> force install OpenGL
3237     Running make
3238     OpenGL-0.4/
3239     OpenGL-0.4/COPYRIGHT
3240     [...]
3241
3242 =item readme, look module or distribution
3243
3244 These two commands take only one argument, be it a module or a
3245 distribution file. C<readme> displays the README of the associated
3246 distribution file. C<Look> gets and untars (if not yet done) the
3247 distribution file, changes to the appropriate directory and opens a
3248 subshell process in that directory.
3249
3250 =back
3251
3252 =head2 CPAN::Shell
3253
3254 The commands that are available in the shell interface are methods in
3255 the package CPAN::Shell. If you enter the shell command, all your
3256 input is split by the Text::ParseWords::shellwords() routine which
3257 acts like most shells do. The first word is being interpreted as the
3258 method to be called and the rest of the words are treated as arguments
3259 to this method.
3260
3261 =head2 autobundle
3262
3263 C<autobundle> writes a bundle file into the
3264 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
3265 a list of all modules that are both available from CPAN and currently
3266 installed within @INC. The name of the bundle file is based on the
3267 current date and a counter.
3268
3269 =head2 recompile
3270
3271 recompile() is a very special command in that it takes no argument and
3272 runs the make/test/install cycle with brute force over all installed
3273 dynamically loadable extensions (aka XS modules) with 'force' in
3274 effect. Primary purpose of this command is to finish a network
3275 installation. Imagine, you have a common source tree for two different
3276 architectures. You decide to do a completely independent fresh
3277 installation. You start on one architecture with the help of a Bundle
3278 file produced earlier. CPAN installs the whole Bundle for you, but
3279 when you try to repeat the job on the second architecture, CPAN
3280 responds with a C<"Foo up to date"> message for all modules. So you
3281 will be glad to run recompile in the second architecture and
3282 youE<39>re done.
3283
3284 Another popular use for C<recompile> is to act as a rescue in case your
3285 perl breaks binary compatibility. If one of the modules that CPAN uses
3286 is in turn depending on binary compatibility (so you cannot run CPAN
3287 commands), then you should try the CPAN::Nox module for recovery.
3288
3289 =head2 The 4 C<CPAN::*> Classes: Author, Bundle, Module, Distribution
3290
3291 Although it may be considered internal, the class hierarchie does
3292 matter for both users and programmer. CPAN.pm deals with above
3293 mentioned four classes, and all those classes share a set of
3294 methods. It is a classical single polymorphism that is in effect.  A
3295 metaclass object registers all objects of all kinds and indexes them
3296 with a string. The strings referencing objects have a separated
3297 namespace (well, not completely separated):
3298
3299          Namespace                         Class
3300
3301    words containing a "/" (slash)      Distribution
3302     words starting with Bundle::          Bundle
3303           everything else            Module or Author
3304
3305 Modules know their associated Distribution objects. They always refer
3306 to the most recent official release. Developers may mark their
3307 releases as unstable development versions (by inserting an underbar
3308 into the visible version number), so not always is the default
3309 distribution for a given module the really hottest and newest. If a
3310 module Foo circulates on CPAN in both version 1.23 and 1.23_90,
3311 CPAN.pm offers a convenient way to install version 1.23 by saying
3312
3313     install Foo
3314
3315 This would install the complete distribution file (say
3316 BAR/Foo-1.23.tar.gz) with all accompanying material in there. But if
3317 you would like to install version 1.23_90, you need to know where the
3318 distribution file resides on CPAN relative to the authors/id/
3319 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz,
3320 so he would have to say
3321
3322     install BAR/Foo-1.23_90.tar.gz
3323
3324 The first example will be driven by an object of the class
3325 CPAN::Module, the second by an object of class Distribution.
3326
3327 =head2 ProgrammerE<39>s interface
3328
3329 If you do not enter the shell, the available shell commands are both
3330 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
3331 functions in the calling package (C<install(...)>).
3332
3333 There's currently only one class that has a stable interface,
3334 CPAN::Shell. All commands that are available in the CPAN shell are
3335 methods of the class CPAN::Shell. Each of the commands that produce
3336 listings of modules (C<r>, C<autobundle>, C<u>) returns a list of the
3337 IDs of all modules within the list.
3338
3339 =over 2
3340
3341 =item expand($type,@things)
3342
3343 The IDs of all objects available within a program are strings that can
3344 be expanded to the corresponding real objects with the
3345 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
3346 list of CPAN::Module objects according to the C<@things> arguments
3347 given. In scalar context it only returns the first element of the
3348 list.
3349
3350 =item Programming Examples
3351
3352 This enables the programmer to do operations that combine
3353 functionalities that are available in the shell.
3354
3355     # install everything that is outdated on my disk:
3356     perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
3357
3358     # install my favorite programs if necessary:
3359     for $mod (qw(Net::FTP MD5 Data::Dumper)){
3360         my $obj = CPAN::Shell->expand('Module',$mod);
3361         $obj->install;
3362     }
3363
3364     # list all modules on my disk that have no VERSION number
3365     for $mod (CPAN::Shell->expand("Module","/./")){
3366         next unless $mod->inst_file;
3367         next if $mod->inst_version;
3368         print "No VERSION in ", $mod->id, "\n";
3369     }
3370
3371 =back
3372
3373 =head2 Methods in the four
3374
3375 =head2 Cache Manager
3376
3377 Currently the cache manager only keeps track of the build directory
3378 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
3379 deletes complete directories below C<build_dir> as soon as the size of
3380 all directories there gets bigger than $CPAN::Config->{build_cache}
3381 (in MB). The contents of this cache may be used for later
3382 re-installations that you intend to do manually, but will never be
3383 trusted by CPAN itself. This is due to the fact that the user might
3384 use these directories for building modules on different architectures.
3385
3386 There is another directory ($CPAN::Config->{keep_source_where}) where
3387 the original distribution files are kept. This directory is not
3388 covered by the cache manager and must be controlled by the user. If
3389 you choose to have the same directory as build_dir and as
3390 keep_source_where directory, then your sources will be deleted with
3391 the same fifo mechanism.
3392
3393 =head2 Bundles
3394
3395 A bundle is just a perl module in the namespace Bundle:: that does not
3396 define any functions or methods. It usually only contains documentation.
3397
3398 It starts like a perl module with a package declaration and a $VERSION
3399 variable. After that the pod section looks like any other pod with the
3400 only difference, that I<one special pod section> exists starting with
3401 (verbatim):
3402
3403         =head1 CONTENTS
3404
3405 In this pod section each line obeys the format
3406
3407         Module_Name [Version_String] [- optional text]
3408
3409 The only required part is the first field, the name of a module
3410 (eg. Foo::Bar, ie. I<not> the name of the distribution file). The rest
3411 of the line is optional. The comment part is delimited by a dash just
3412 as in the man page header.
3413
3414 The distribution of a bundle should follow the same convention as
3415 other distributions.
3416
3417 Bundles are treated specially in the CPAN package. If you say 'install
3418 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
3419 the modules in the CONTENTS section of the pod.  You can install your
3420 own Bundles locally by placing a conformant Bundle file somewhere into
3421 your @INC path. The autobundle() command which is available in the
3422 shell interface does that for you by including all currently installed
3423 modules in a snapshot bundle file.
3424
3425 There is a meaningless Bundle::Demo available on CPAN. Try to install
3426 it, it usually does no harm, just demonstrates what the Bundle
3427 interface looks like.
3428
3429 =head2 Prerequisites
3430
3431 If you have a local mirror of CPAN and can access all files with
3432 "file:" URLs, then you only need a perl better than perl5.003 to run
3433 this module. Otherwise Net::FTP is strongly recommended. LWP may be
3434 required for non-UNIX systems or if your nearest CPAN site is
3435 associated with an URL that is not C<ftp:>.
3436
3437 If you have neither Net::FTP nor LWP, there is a fallback mechanism
3438 implemented for an external ftp command or for an external lynx
3439 command.
3440
3441 This module presumes that all packages on CPAN
3442
3443 =over 2
3444
3445 =item *
3446
3447 declare their $VERSION variable in an easy to parse manner. This
3448 prerequisite can hardly be relaxed because it consumes by far too much
3449 memory to load all packages into the running program just to determine
3450 the $VERSION variable . Currently all programs that are dealing with
3451 version use something like this
3452
3453     perl -MExtUtils::MakeMaker -le \
3454         'print MM->parse_version($ARGV[0])' filename
3455
3456 If you are author of a package and wonder if your $VERSION can be
3457 parsed, please try the above method.
3458
3459 =item *
3460
3461 come as compressed or gzipped tarfiles or as zip files and contain a
3462 Makefile.PL (well we try to handle a bit more, but without much
3463 enthusiasm).
3464
3465 =back
3466
3467 =head2 Debugging
3468
3469 The debugging of this module is pretty difficult, because we have
3470 interferences of the software producing the indices on CPAN, of the
3471 mirroring process on CPAN, of packaging, of configuration, of
3472 synchronicity, and of bugs within CPAN.pm.
3473
3474 In interactive mode you can try "o debug" which will list options for
3475 debugging the various parts of the package. The output may not be very
3476 useful for you as it's just a byproduct of my own testing, but if you
3477 have an idea which part of the package may have a bug, it's sometimes
3478 worth to give it a try and send me more specific output. You should
3479 know that "o debug" has built-in completion support.
3480
3481 =head2 Floppy, Zip, and all that Jazz
3482
3483 CPAN.pm works nicely without network too. If you maintain machines
3484 that are not networked at all, you should consider working with file:
3485 URLs. Of course, you have to collect your modules somewhere first. So
3486 you might use CPAN.pm to put together all you need on a networked
3487 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
3488 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
3489 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
3490 with this floppy.
3491
3492 =head1 CONFIGURATION
3493
3494 When the CPAN module is installed a site wide configuration file is
3495 created as CPAN/Config.pm. The default values defined there can be
3496 overridden in another configuration file: CPAN/MyConfig.pm. You can
3497 store this file in $HOME/.cpan/CPAN/MyConfig.pm if you want, because
3498 $HOME/.cpan is added to the search path of the CPAN module before the
3499 use() or require() statements.
3500
3501 Currently the following keys in the hash reference $CPAN::Config are
3502 defined:
3503
3504   build_cache        size of cache for directories to build modules
3505   build_dir          locally accessible directory to build modules
3506   index_expire       after how many days refetch index files
3507   cpan_home          local directory reserved for this package
3508   gzip               location of external program gzip
3509   inactivity_timeout breaks interactive Makefile.PLs after that
3510                      many seconds inactivity. Set to 0 to never break.
3511   inhibit_startup_message
3512                      if true, does not print the startup message
3513   keep_source        keep the source in a local directory?
3514   keep_source_where  where keep the source (if we do)
3515   make               location of external program make
3516   make_arg           arguments that should always be passed to 'make'
3517   make_install_arg   same as make_arg for 'make install'
3518   makepl_arg         arguments passed to 'perl Makefile.PL'
3519   pager              location of external program more (or any pager)
3520   tar                location of external program tar
3521   unzip              location of external program unzip
3522   urllist            arrayref to nearby CPAN sites (or equivalent locations)
3523
3524 You can set and query each of these options interactively in the cpan
3525 shell with the command set defined within the C<o conf> command:
3526
3527 =over 2
3528
3529 =item o conf E<lt>scalar optionE<gt>
3530
3531 prints the current value of the I<scalar option>
3532
3533 =item o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>
3534
3535 Sets the value of the I<scalar option> to I<value>
3536
3537 =item o conf E<lt>list optionE<gt>
3538
3539 prints the current value of the I<list option> in MakeMaker's
3540 neatvalue format.
3541
3542 =item o conf E<lt>list optionE<gt> [shift|pop]
3543
3544 shifts or pops the array in the I<list option> variable
3545
3546 =item o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>
3547
3548 works like the corresponding perl commands.
3549
3550 =back
3551
3552 =head1 SECURITY
3553
3554 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
3555 install foreign, unmasked, unsigned code on your machine. We compare
3556 to a checksum that comes from the net just as the distribution file
3557 itself. If somebody has managed to tamper with the distribution file,
3558 they may have as well tampered with the CHECKSUMS file. Future
3559 development will go towards strong authentification.
3560
3561 =head1 EXPORT
3562
3563 Most functions in package CPAN are exported per default. The reason
3564 for this is that the primary use is intended for the cpan shell or for
3565 oneliners.
3566
3567 =head1 BUGS
3568
3569 we should give coverage for _all_ of the CPAN and not just the
3570 __PAUSE__ part, right? In this discussion CPAN and PAUSE have become
3571 equal -- but they are not. PAUSE is authors/ and modules/. CPAN is
3572 PAUSE plus the clpa/, doc/, misc/, ports/, src/, scripts/.
3573
3574 Future development should be directed towards a better intergration of
3575 the other parts.
3576
3577 =head1 AUTHOR
3578
3579 Andreas König E<lt>a.koenig@mind.deE<gt>
3580
3581 =head1 SEE ALSO
3582
3583 perl(1), CPAN::Nox(3)
3584
3585 =cut
3586