lib/CPAN.pm

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