lib/CPAN.pm

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