lib/CPAN.pm

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