lib/CPAN.pm

   1 package CPAN;
   2 use vars qw{$META $Signal $Cwd $End $Suppress_readline};
   3
   4 $VERSION = '1.08';
   5
   6 # $Id: CPAN.pm,v 1.92 1996/12/23 13:13:05 k Exp $
   7
   8 # my $version = substr q$Revision: 1.92 $, 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->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                     local(*WTR);
 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(WTR, "|$CPAN::Config->{'ftp'} $host") or die "Couldn't open ftp: $!";
 878                     # pilot blind
 879                     for (@dialog) {
 880 #                       print "To WTR>>$_<<\n";
 881                         print WTR $_;
 882                     }
 883 #                   close WTR;
 884                     chdir($cwd);
 885                     return $aslocal;
 886                 } else {
 887                     my($netrcfile) = $netrc->{netrc};
 888                     if ($netrcfile) {
 889                         print qq{  Your $netrcfile does not contain host $host.\n}
 890                     } else {
 891                         print qq{  I could not find or open your $netrcfile.\n}
 892                     }
 893                     print qq{  If you want to use external ftp,
 894   please enter host $host into your .netrc file and retry.
 895
 896   The format of a proper entry in your .netrc file would be:
 897
 898 machine $host
 899 login ftp
 900 password $Config::Config{cf_email}
 901
 902 Please make also sure, your .netrc will not be readable by others.
 903 You don\'t have to leave and restart CPAN.pm, I\'ll look again next
 904 time I come around here.
 905 \n};
 906                 }
 907             }
 908         }
 909         if (-x $CPAN::Config->{'lynx'}) {
 910 ##          $self->debug("Trying with lynx for [$url]") if $CPAN::DEBUG;
 911             my($want_compressed);
 912             print(
 913                   qq{
 914   Trying with lynx to get $url
 915   As lynx has so many options and versions, we\'re not sure, that we
 916   get it right. It is recommended that you install Net::FTP as soon
 917   as possible. Just type "install Net::FTP". Thank you.
 918
 919 }
 920                  );
 921             $want_compressed = $aslocal =~ s/\.gz//;
 922             my($system) = "$CPAN::Config->{'lynx'} -source '$url' > $aslocal";
 923             if (system($system)==0) {
 924                 if ($want_compressed) {
 925                     $system = "$CPAN::Config->{'gzip'} -dt $aslocal";
 926                     if (system($system)==0) {
 927                         rename $aslocal, "$aslocal.gz";
 928                     } else {
 929                         $system = "$CPAN::Config->{'gzip'} $aslocal";
 930                         system($system);
 931                     }
 932                     return "$aslocal.gz";
 933                 } else {
 934                     $system = "$CPAN::Config->{'gzip'} -dt $aslocal";
 935                     if (system($system)==0) {
 936                         $system = "$CPAN::Config->{'gzip'} -d $aslocal";
 937                         system($system);
 938                     } else {
 939                         # should be fine, eh?
 940                     }
 941                     return $aslocal;
 942                 }
 943             }
 944         }
 945         warn "Can't access URL $url.
 946   Either get LWP or Net::FTP
 947   or an external lynx or ftp";
 948     }
 949     Carp::croak("Cannot fetch $file from anywhere");
 950 }
 951
 952 package CPAN::FTP::external;
 953
 954 package CPAN::FTP::netrc;
 955
 956 sub new {
 957     my($class) = @_;
 958     my $file = MY->catfile($ENV{HOME},".netrc");
 959     my($fh,@machines);
 960     if($fh = IO::File->new($file,"r")){
 961         local($/) = "";
 962         while (<$fh>) {
 963             next if /\bmacdef\b/;
 964             my($machine) = /\bmachine\s+(\S+)/s;
 965             push @machines, $machine;
 966         }
 967     } else {
 968         $file = "";
 969     }
 970     bless {
 971            mach => [@machines],
 972            netrc => $file,
 973           }, $class;
 974 }
 975
 976 sub contains {
 977     my($self,$mach) = @_;
 978     scalar grep {$_ eq $mach} @{$self->{mach}};
 979 }
 980
 981 package CPAN::Complete;
 982 @CPAN::Complete::ISA = qw(CPAN::Debug);
 983
 984 #-> sub CPAN::Complete::complete ;
 985 sub complete {
 986     my($word,$line,$pos) = @_;
 987     $word ||= "";
 988     $line ||= "";
 989     $pos ||= 0;
 990     CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
 991     $line =~ s/^\s*//;
 992     my @return;
 993     if ($pos == 0) {
 994         @return = grep(/^$word/, sort qw(! a b d h i m o q r u autobundle clean make test install reload));
 995     } elsif ( $line !~ /^[\!abdhimorut]/ ) {
 996         @return = ();
 997     } elsif ($line =~ /^a\s/) {
 998         @return = completex('CPAN::Author',$word);
 999     } elsif ($line =~ /^b\s/) {
1000         @return = completex('CPAN::Bundle',$word);
1001     } elsif ($line =~ /^d\s/) {
1002         @return = completex('CPAN::Distribution',$word);
1003     } elsif ($line =~ /^([mru]\s|(make|clean|test|install)\s)/ ) {
1004         @return = (completex('CPAN::Module',$word),completex('CPAN::Bundle',$word));
1005     } elsif ($line =~ /^i\s/) {
1006         @return = complete_any($word);
1007     } elsif ($line =~ /^reload\s/) {
1008         @return = complete_reload($word,$line,$pos);
1009     } elsif ($line =~ /^o\s/) {
1010         @return = complete_option($word,$line,$pos);
1011     } else {
1012         @return = ();
1013     }
1014     return @return;
1015 }
1016
1017 #-> sub CPAN::Complete::completex ;
1018 sub completex {
1019     my($class, $word) = @_;
1020     grep /^\Q$word\E/, map { $_->id } $CPAN::META->all($class);
1021 }
1022
1023 #-> sub CPAN::Complete::complete_any ;
1024 sub complete_any {
1025     my($word) = shift;
1026     return (
1027             completex('CPAN::Author',$word),
1028             completex('CPAN::Bundle',$word),
1029             completex('CPAN::Distribution',$word),
1030             completex('CPAN::Module',$word),
1031            );
1032 }
1033
1034 #-> sub CPAN::Complete::complete_reload ;
1035 sub complete_reload {
1036     my($word,$line,$pos) = @_;
1037     $word ||= "";
1038     my(@words) = split " ", $line;
1039     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
1040     my(@ok) = qw(cpan index);
1041     return @ok if @words==1;
1042     return grep /^\Q$word\E/, @ok if @words==2 && $word;
1043 }
1044
1045 #-> sub CPAN::Complete::complete_option ;
1046 sub complete_option {
1047     my($word,$line,$pos) = @_;
1048     $word ||= "";
1049     my(@words) = split " ", $line;
1050     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
1051     my(@ok) = qw(conf debug);
1052     return @ok if @words==1;
1053     return grep /^\Q$word\E/, @ok if @words==2 && $word;
1054     if (0) {
1055     } elsif ($words[1] eq 'index') {
1056         return ();
1057     } elsif ($words[1] eq 'conf') {
1058         return CPAN::Config::complete(@_);
1059     } elsif ($words[1] eq 'debug') {
1060         return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all';
1061     }
1062 }
1063
1064 package CPAN::Index;
1065 use vars qw($last_time);
1066 @CPAN::Index::ISA = qw(CPAN::Debug);
1067 $last_time ||= 0;
1068
1069 #-> sub CPAN::Index::force_reload ;
1070 sub force_reload {
1071     my($class) = @_;
1072     $CPAN::Index::last_time = 0;
1073     $class->reload(1);
1074 }
1075
1076 #-> sub CPAN::Index::reload ;
1077 sub reload {
1078     my($cl,$force) = @_;
1079     my $time = time;
1080
1081     # XXX check if a newer one is available. (We currently read it from time to time)
1082     return if $last_time + $CPAN::Config->{index_expire}*86400 > $time;
1083     $last_time = $time;
1084
1085     $cl->read_authindex($cl->reload_x("authors/01mailrc.txt.gz","01mailrc.gz",$force));
1086     return if $CPAN::Signal; # this is sometimes lengthy
1087     $cl->read_modpacks($cl->reload_x("modules/02packages.details.txt.gz","02packag.gz",$force));
1088     return if $CPAN::Signal; # this is sometimes lengthy
1089     $cl->read_modlist($cl->reload_x("modules/03modlist.data.gz","03mlist.gz",$force));
1090 }
1091
1092 #-> sub CPAN::Index::reload_x ;
1093 sub reload_x {
1094     my($cl,$wanted,$localname,$force) = @_;
1095     $force ||= 0;
1096     my $abs_wanted = CPAN->catfile($CPAN::Config->{'keep_source_where'},$localname);
1097     if (-f $abs_wanted && -M $abs_wanted < $CPAN::Config->{'index_expire'} && !$force) {
1098         my($s) = $CPAN::Config->{'index_expire'} != 1;
1099         $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} day$s. I\'ll use that.\n});
1100         return $abs_wanted;
1101     } else {
1102         $force ||= 1;
1103     }
1104     return CPAN::FTP->localize($wanted,$abs_wanted,$force);
1105 }
1106
1107 #-> sub CPAN::Index::read_authindex ;
1108 sub read_authindex {
1109     my($cl,$index_target) = @_;
1110     my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target";
1111     warn "Going to read $index_target\n";
1112     my $fh = IO::File->new("$pipe|");
1113     while (<$fh>) {
1114         chomp;
1115         my($userid,$fullname,$email) = /alias\s+(\S+)\s+\"([^\"\<]+)\s+<([^\>]+)\>\"/;
1116         next unless $userid && $fullname && $email;
1117
1118         # instantiate an author object
1119         my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
1120         $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
1121         return if $CPAN::Signal;
1122     }
1123     $fh->close;
1124     $? and Carp::croak "FAILED $pipe: exit status [$?]";
1125 }
1126
1127 #-> sub CPAN::Index::read_modpacks ;
1128 sub read_modpacks {
1129     my($cl,$index_target) = @_;
1130     my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target";
1131     warn "Going to read $index_target\n";
1132     my $fh = IO::File->new("$pipe|");
1133     while (<$fh>) {
1134         next if 1../^\s*$/;
1135         chomp;
1136         my($mod,$version,$dist) = split;
1137         $version =~ s/^\+//;
1138
1139         # if it as a bundle, instatiate a bundle object
1140         my($bundle);
1141         if ($mod =~ /^Bundle::(.*)/) {
1142             $bundle = $1;
1143         }
1144
1145         if ($mod eq 'CPAN') {
1146             local($^W)=0;
1147             if ($version > $CPAN::VERSION){
1148                 print qq{
1149   Hey, you know what? There\'s a new CPAN.pm version (v$version)
1150   available! I\'d suggest--provided you have time--you try
1151     install CPAN
1152     reload cpan
1153   without quitting the current session. It should be a seemless upgrade
1154   while we are running...
1155 };
1156                 sleep 2;
1157                 print qq{\n};
1158             }
1159         }
1160
1161         my($id);
1162         if ($bundle){
1163             $id =  $CPAN::META->instance('CPAN::Bundle',$mod);
1164             $id->set('CPAN_VERSION' => $version, 'CPAN_FILE' => $dist);
1165 # This "next" makes us faster but if the job is running long, we ignore
1166 # rereads which is bad. So we have to be a bit slower again.
1167 #       } elsif ($CPAN::META->exists('CPAN::Module',$mod)) {
1168 #           next;
1169         } else {
1170             # instantiate a module object
1171             $id = $CPAN::META->instance('CPAN::Module',$mod);
1172             $id->set('CPAN_VERSION' => $version, 'CPAN_FILE' => $dist);
1173         }
1174
1175         # determine the author
1176         my($userid) = $dist =~ /([^\/]+)/;
1177         $id->set('CPAN_USERID' => $userid) if $userid =~ /\w/;
1178
1179         # instantiate a distribution object
1180         unless ($CPAN::META->exists('CPAN::Distribution',$dist)) {
1181             $CPAN::META->instance(
1182                                   'CPAN::Distribution' => $dist
1183                                  )->set(
1184                                         'CPAN_USERID' => $userid
1185                                        )
1186                                      if $userid =~ /\w/;
1187         }
1188
1189         return if $CPAN::Signal;
1190     }
1191     $fh->close;
1192     $? and Carp::croak "FAILED $pipe: exit status [$?]";
1193 }
1194
1195 #-> sub CPAN::Index::read_modlist ;
1196 sub read_modlist {
1197     my($cl,$index_target) = @_;
1198     my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target";
1199     warn "Going to read $index_target\n";
1200     my $fh = IO::File->new("$pipe|");
1201     my $eval = "";
1202     while (<$fh>) {
1203         next if 1../^\s*$/;
1204         next if /use vars/; # will go away in 03...
1205         $eval .= $_;
1206         return if $CPAN::Signal;
1207     }
1208     $eval .= q{CPAN::Modulelist->data;};
1209     local($^W) = 0;
1210     my($comp) = Safe->new("CPAN::Safe1");
1211     my $ret = $comp->reval($eval);
1212     Carp::confess($@) if $@;
1213     return if $CPAN::Signal;
1214     for (keys %$ret) {
1215         my $obj = $CPAN::META->instance(CPAN::Module,$_);
1216         $obj->set(%{$ret->{$_}});
1217         return if $CPAN::Signal;
1218     }
1219 }
1220
1221 package CPAN::InfoObj;
1222 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
1223
1224 #-> sub CPAN::InfoObj::new ;
1225 sub new { my $this = bless {}, shift; %$this = @_; $this }
1226
1227 #-> sub CPAN::InfoObj::set ;
1228 sub set {
1229     my($self,%att) = @_;
1230     my(%oldatt) = %$self;
1231     %$self = (%oldatt, %att);
1232 }
1233
1234 #-> sub CPAN::InfoObj::id ;
1235 sub id { shift->{'ID'} }
1236
1237 #-> sub CPAN::InfoObj::as_glimpse ;
1238 sub as_glimpse {
1239     my($self) = @_;
1240     my(@m);
1241     my $class = ref($self);
1242     $class =~ s/^CPAN:://;
1243     push @m, sprintf "%-15s %s\n", $class, $self->{ID};
1244     join "", @m;
1245 }
1246
1247 #-> sub CPAN::InfoObj::as_string ;
1248 sub as_string {
1249     my($self) = @_;
1250     my(@m);
1251     my $class = ref($self);
1252     $class =~ s/^CPAN:://;
1253     push @m, $class, " id = $self->{ID}\n";
1254     for (sort keys %$self) {
1255         next if $_ eq 'ID';
1256         my $extra = "";
1257         $_ eq "CPAN_USERID" and $extra = " (".$self->author.")";
1258         if (ref $self->{$_}) { # Should we setup a language interface? XXX
1259             push @m, sprintf "    %-12s %s%s\n", $_, "@{$self->{$_}}", $extra;
1260         } else {
1261             push @m, sprintf "    %-12s %s%s\n", $_, $self->{$_}, $extra;
1262         }
1263     }
1264     join "", @m, "\n";
1265 }
1266
1267 #-> sub CPAN::InfoObj::author ;
1268 sub author {
1269     my($self) = @_;
1270     $CPAN::META->instance(CPAN::Author,$self->{CPAN_USERID})->fullname;
1271 }
1272
1273 package CPAN::Author;
1274 @CPAN::Author::ISA = qw(CPAN::Debug CPAN::InfoObj);
1275
1276 #-> sub CPAN::Author::as_glimpse ;
1277 sub as_glimpse {
1278     my($self) = @_;
1279     my(@m);
1280     my $class = ref($self);
1281     $class =~ s/^CPAN:://;
1282     push @m, sprintf "%-15s %s (%s)\n", $class, $self->{ID}, $self->fullname;
1283     join "", @m;
1284 }
1285
1286 # Dead code, I would have liked to have,,, but it was never reached,,,
1287 #sub make {
1288 #    my($self) = @_;
1289 #    return "Don't be silly, you can't make $self->{FULLNAME} ;-)\n";
1290 #}
1291
1292 #-> sub CPAN::Author::fullname ;
1293 sub fullname { shift->{'FULLNAME'} }
1294 *name = \&fullname;
1295 #-> sub CPAN::Author::email ;
1296 sub email    { shift->{'EMAIL'} }
1297
1298 package CPAN::Distribution;
1299 @CPAN::Distribution::ISA = qw(CPAN::Debug CPAN::InfoObj);
1300
1301 #-> sub CPAN::Distribution::called_for ;
1302 sub called_for {
1303     my($self,$id) = @_;
1304     $self->{'CALLED_FOR'} = $id if defined $id;
1305     return $self->{'CALLED_FOR'};
1306 }
1307
1308 #-> sub CPAN::Distribution::get ;
1309 sub get {
1310     my($self) = @_;
1311   EXCUSE: {
1312         my @e;
1313         exists $self->{'build_dir'} and push @e, "Unwrapped into directory $self->{'build_dir'}";
1314         print join "", map {"  $_\n"} @e and return if @e;
1315     }
1316     my($local_file);
1317     my($local_wanted) =
1318          CPAN->catfile(
1319                         $CPAN::Config->{keep_source_where},
1320                         "authors",
1321                         "id",
1322                         split("/",$self->{ID})
1323                        );
1324
1325     $self->debug("Doing localize") if $CPAN::DEBUG;
1326     $local_file = CPAN::FTP->localize("authors/id/$self->{ID}", $local_wanted);
1327     $self->{localfile} = $local_file;
1328     my $builddir = $CPAN::META->{cachemgr}->dir;
1329     $self->debug("doing chdir $builddir") if $CPAN::DEBUG;
1330     chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
1331     my $packagedir;
1332
1333     $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
1334     if ($local_file =~ /(\.tar\.(gz|Z)|\.tgz|\.zip)$/i){
1335         $self->debug("Removing tmp") if $CPAN::DEBUG;
1336         File::Path::rmtree("tmp");
1337         mkdir "tmp", 0777 or Carp::croak "Couldn't mkdir tmp: $!";
1338         chdir "tmp";
1339         $self->debug("Changed directory to tmp") if $CPAN::DEBUG;
1340         if ($local_file =~ /z$/i){
1341             $self->{archived} = "tar";
1342             if (system("$CPAN::Config->{gzip} --decompress --stdout $local_file | $CPAN::Config->{tar} xvf -")==0) {
1343                 $self->{unwrapped} = "YES";
1344             } else {
1345                 $self->{unwrapped} = "NO";
1346             }
1347         } elsif ($local_file =~ /zip$/i) {
1348             $self->{archived} = "zip";
1349             if (system("$CPAN::Config->{unzip} $local_file")==0) {
1350                 $self->{unwrapped} = "YES";
1351             } else {
1352                 $self->{unwrapped} = "NO";
1353             }
1354         }
1355         # Let's check if the package has its own directory.
1356         opendir DIR, "." or Carp::croak("Weird: couldn't opendir .: $!");
1357         my @readdir = grep $_ !~ /^\.\.?$/, readdir DIR; ### MAC??
1358         closedir DIR;
1359         my ($distdir,$packagedir);
1360         if (@readdir == 1 && -d $readdir[0]) {
1361             $distdir = $readdir[0];
1362             $packagedir = $CPAN::META->catdir($builddir,$distdir);
1363             -d $packagedir and print "Removing previously used $packagedir\n";
1364             File::Path::rmtree($packagedir);
1365             rename($distdir,$packagedir) or Carp::confess("Couldn't rename $distdir to $packagedir: $!");
1366         } else {
1367             my $pragmatic_dir = $self->{'CPAN_USERID'} . '000';
1368             $pragmatic_dir =~ s/\W_//g;
1369             $pragmatic_dir++ while -d "../$pragmatic_dir";
1370             $packagedir = $CPAN::META->catdir($builddir,$pragmatic_dir);
1371             File::Path::mkpath($packagedir);
1372             my($f);
1373             for $f (@readdir) { # is already without "." and ".."
1374                 my $to = $CPAN::META->catdir($packagedir,$f);
1375                 rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
1376             }
1377         }
1378         $self->{'build_dir'} = $packagedir;
1379
1380         chdir "..";
1381         $self->debug("Changed directory to .. (self is $self [".$self->as_string."])") if $CPAN::DEBUG;
1382         File::Path::rmtree("tmp");
1383         if ($CPAN::Config->{keep_source_where} =~ /^no/i ){
1384             print "Going to unlink $local_file\n";
1385             unlink $local_file or Carp::carp "Couldn't unlink $local_file";
1386         }
1387         my($makefilepl) = $CPAN::META->catfile($packagedir,"Makefile.PL");
1388         unless (-f $makefilepl) {
1389             my($configure) = $CPAN::META->catfile($packagedir,"Configure");
1390             if (-f $configure) {
1391                 # do we have anything to do?
1392                 $self->{'configure'} = $configure;
1393             } else {
1394                 my $fh = IO::File->new(">$makefilepl") or Carp::croak("Could not open >$makefilepl");
1395                 my $cf = $self->called_for || "unknown";
1396                 $fh->print(qq{
1397 # This Makefile.PL has been autogenerated by the module CPAN.pm
1398 # Autogenerated on: }.scalar localtime().qq{
1399                     use ExtUtils::MakeMaker;
1400                     WriteMakefile(NAME => q[$cf]);
1401 });
1402                 print qq{Package comes without Makefile.PL.\n}.
1403                     qq{  Writing one on our own (calling it $cf)\n};
1404             }
1405         }
1406     } else {
1407         $self->{archived} = "NO";
1408     }
1409     return $self;
1410 }
1411
1412 #-> sub CPAN::Distribution::new ;
1413 sub new {
1414     my($class,%att) = @_;
1415
1416     $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
1417
1418     my $this = { %att };
1419     return bless $this, $class;
1420 }
1421
1422 #-> sub CPAN::Distribution::readme ;
1423 sub readme {
1424     my($self) = @_;
1425     print "Readme not yet implemented (says ".$self->id.")\n";
1426 }
1427
1428 #-> sub CPAN::Distribution::verifyMD5 ;
1429 sub verifyMD5 {
1430     my($self) = @_;
1431   EXCUSE: {
1432         my @e;
1433         $self->{MD5_STATUS} and push @e, "MD5 Checksum was ok";
1434         print join "", map {"  $_\n"} @e and return if @e;
1435     }
1436     my($local_file);
1437     my(@local) = split("/",$self->{ID});
1438     my($basename) = pop @local;
1439     push @local, "CHECKSUMS";
1440     my($local_wanted) =
1441         CPAN->catfile(
1442                       $CPAN::Config->{keep_source_where},
1443                       "authors",
1444                       "id",
1445                       @local
1446                      );
1447     local($") = "/";
1448     if (
1449         -f $local_wanted
1450         &&
1451         $self->MD5_check_file($local_wanted,$basename)
1452        ) {
1453         return $self->{MD5_STATUS}="OK";
1454     }
1455     $local_file = CPAN::FTP->localize("authors/id/@local", $local_wanted, 'force>:-{');
1456     my($checksum_pipe);
1457     if ($local_file) {
1458         # fine
1459     } else {
1460         $local[-1] .= ".gz";
1461         $local_file = CPAN::FTP->localize(
1462                                           "authors/id/@local",
1463                                           "$local_wanted.gz",
1464                                           'force>:-{'
1465                                          );
1466         my $system = "$CPAN::Config->{gzip} --decompress $local_file";
1467         system($system)==0 or die "Could not uncompress $local_file";
1468         $local_file =~ s/\.gz$//;
1469     }
1470     $self->MD5_check_file($local_file,$basename);
1471 }
1472
1473 #-> sub CPAN::Distribution::MD5_check_file ;
1474 sub MD5_check_file {
1475     my($self,$lfile,$basename) = @_;
1476     my($cksum);
1477     my $fh = new IO::File;
1478     local($/)=undef;
1479     if (open $fh, $lfile){
1480         my $eval = <$fh>;
1481         close $fh;
1482         my($comp) = Safe->new();
1483         $cksum = $comp->reval($eval);
1484         Carp::confess($@) if $@;
1485         if ($cksum->{$basename}->{md5}) {
1486             $self->debug("Found checksum for $basename: $cksum->{$basename}->{md5}\n") if $CPAN::DEBUG;
1487             my $file = $self->{localfile};
1488             my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $self->{localfile}|";
1489             if (
1490                 open($fh, $file) && $self->eq_MD5($fh,$cksum->{$basename}->{md5})
1491                 or
1492                 open($fh, $pipe) && $self->eq_MD5($fh,$cksum->{$basename}->{'md5-ungz'})
1493                ){
1494                 print "Checksum for $file ok\n";
1495                 return $self->{MD5_STATUS}="OK";
1496             } else {
1497                 die join(
1498                          "",
1499                          "\nChecksum mismatch for distribution file. Please investigate.\n\n",
1500                          $self->as_string,
1501                          $CPAN::META->instance('CPAN::Author',$self->{CPAN_USERID})->as_string,
1502                          "Please contact the author or your CPAN site admin"
1503                         );
1504             }
1505             close $fh if fileno($fh);
1506         } else {
1507             print "No md5 checksum for $basename in local $lfile\n";
1508             return;
1509         }
1510     } else {
1511         Carp::carp "Could not open $lfile for reading";
1512     }
1513 }
1514
1515 #-> sub CPAN::Distribution::eq_MD5 ;
1516 sub eq_MD5 {
1517     my($self,$fh,$expectMD5) = @_;
1518     my $md5 = new MD5;
1519     $md5->addfile($fh);
1520     my $hexdigest = $md5->hexdigest;
1521     $hexdigest eq $expectMD5;
1522 }
1523
1524 #-> sub CPAN::Distribution::force ;
1525 sub force {
1526     my($self) = @_;
1527     $self->{'force_update'}++;
1528     delete $self->{'MD5_STATUS'};
1529     delete $self->{'archived'};
1530     delete $self->{'build_dir'};
1531     delete $self->{'localfile'};
1532     delete $self->{'make'};
1533     delete $self->{'install'};
1534     delete $self->{'unwrapped'};
1535     delete $self->{'writemakefile'};
1536 }
1537
1538 #-> sub CPAN::Distribution::make ;
1539 sub make {
1540     my($self) = @_;
1541     $self->debug($self->id) if $CPAN::DEBUG;
1542     print "Running make\n";
1543     $self->get;
1544     if ($CPAN::META->hasMD5) {
1545         $self->verifyMD5;
1546     }
1547     EXCUSE: {
1548           my @e;
1549           $self->{archived} eq "NO" and push @e, "Is neither a tar nor a zip archive.";
1550           $self->{unwrapped} eq "NO"   and push @e, "had problems unarchiving. Please build manually";
1551           exists $self->{writemakefile} && $self->{writemakefile} eq "NO" and push @e, "Had some problem writing Makefile";
1552           defined $self->{'make'} and push @e, "Has already been processed within this session";
1553           print join "", map {"  $_\n"} @e and return if @e;
1554      }
1555     print "\n  CPAN: Going to build ".$self->id."\n\n";
1556     my $builddir = $self->dir;
1557     chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
1558     $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
1559
1560     my $system;
1561     if ($self->{'configure'}) {
1562         $system = $self->{'configure'};
1563     } else {
1564         my($perl) = $^X =~ /^\.\// ? "$CPAN::Cwd/$^X" : $^X; # XXX subclassing folks, forgive me!
1565         $system = "$perl Makefile.PL $CPAN::Config->{makepl_arg}";
1566     }
1567     $SIG{ALRM} = sub { die "inactivity_timeout reached\n" };
1568     my($ret,$pid);
1569     $@ = "";
1570     if ($CPAN::Config->{inactivity_timeout}) {
1571         eval {
1572             alarm $CPAN::Config->{inactivity_timeout};
1573             #$SIG{CHLD} = \&REAPER;
1574             if (defined($pid=fork)) {
1575                 if ($pid) { #parent
1576                     wait;
1577                 } else {    #child
1578                     exec $system;
1579                 }
1580             } else {
1581                 print "Cannot fork: $!";
1582                 return;
1583             }
1584             $ret = system($system);
1585         };
1586         alarm 0;
1587     } else {
1588         $ret = system($system);
1589     }
1590     if ($@){
1591         kill 9, $pid;
1592         waitpid $pid, 0;
1593         print $@;
1594         $self->{writemakefile} = "NO - $@";
1595         $@ = "";
1596         return;
1597     } elsif ($ret != 0) {
1598          $self->{writemakefile} = "NO";
1599          return;
1600     }
1601     $self->{writemakefile} = "YES";
1602     return if $CPAN::Signal;
1603     $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
1604     if (system($system)==0) {
1605          print "  $system -- OK\n";
1606          $self->{'make'} = "YES";
1607     } else {
1608          $self->{writemakefile} = "YES";
1609          $self->{'make'} = "NO";
1610          print "  $system -- NOT OK\n";
1611     }
1612 }
1613
1614 #-> sub CPAN::Distribution::test ;
1615 sub test {
1616     my($self) = @_;
1617     $self->make;
1618     return if $CPAN::Signal;
1619     print "Running make test\n";
1620     EXCUSE: {
1621           my @e;
1622           exists $self->{'make'} or push @e, "Make had some problems, maybe interrupted? Won't test";
1623           exists $self->{'make'} and $self->{'make'} eq 'NO' and push @e, "Oops, make had returned bad status";
1624           exists $self->{'build_dir'} or push @e, "Has no own directory";
1625           print join "", map {"  $_\n"} @e and return if @e;
1626      }
1627     chdir $self->{'build_dir'} or Carp::croak("Couldn't chdir to $self->{'build_dir'}");
1628     $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
1629     my $system = join " ", $CPAN::Config->{'make'}, "test";
1630     if (system($system)==0) {
1631          print "  $system -- OK\n";
1632          $self->{'make_test'} = "YES";
1633     } else {
1634          $self->{'make_test'} = "NO";
1635          print "  $system -- NOT OK\n";
1636     }
1637 }
1638
1639 #-> sub CPAN::Distribution::clean ;
1640 sub clean {
1641     my($self) = @_;
1642     print "Running make clean\n";
1643     EXCUSE: {
1644           my @e;
1645           exists $self->{'build_dir'} or push @e, "Has no own directory";
1646           print join "", map {"  $_\n"} @e and return if @e;
1647      }
1648     chdir $self->{'build_dir'} or Carp::croak("Couldn't chdir to $self->{'build_dir'}");
1649     $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
1650     my $system = join " ", $CPAN::Config->{'make'}, "clean";
1651     if (system($system)==0) {
1652         print "  $system -- OK\n";
1653         $self->force;
1654     } else {
1655         # Hmmm, what to do if make clean failed?
1656     }
1657 }
1658
1659 #-> sub CPAN::Distribution::install ;
1660 sub install {
1661     my($self) = @_;
1662     $self->test;
1663     return if $CPAN::Signal;
1664     print "Running make install\n";
1665     EXCUSE: {
1666           my @e;
1667           exists $self->{'build_dir'} or push @e, "Has no own directory";
1668           exists $self->{'make'} or push @e, "Make had some problems, maybe interrupted? Won't install";
1669           exists $self->{'make'} and $self->{'make'} eq 'NO' and push @e, "Oops, make had returned bad status";
1670           exists $self->{'install'} and push @e, $self->{'install'} eq "YES" ? "Already done" : "Already tried without success";
1671           print join "", map {"  $_\n"} @e and return if @e;
1672      }
1673     chdir $self->{'build_dir'} or Carp::croak("Couldn't chdir to $self->{'build_dir'}");
1674     $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
1675     my $system = join " ", $CPAN::Config->{'make'}, "install", $CPAN::Config->{make_install_arg};
1676     my($pipe) = IO::File->new("$system 2>&1 |");
1677     my($makeout) = "";
1678
1679  # #If I were to try this, I'd do something like:
1680  # #
1681  # #  $SIG{ALRM} = sub { die "alarm\n" };
1682  # #
1683  # #  open(PROC,"make somesuch|");
1684  # #  eval {
1685  # #    alarm 30;
1686  # #    while(<PROC>) {
1687  # #      alarm 30;
1688  # #    }
1689  # #  }
1690  # #  close(PROC);
1691  # #  alarm 0;
1692  # #
1693  # #I'm really not sure how reliable this would is, though.
1694  # #
1695  # #--
1696  # #Kenneth Albanowski (kjahds@kjahds.com, CIS: 70705,126)
1697  # #
1698  # #
1699  # #
1700  # #
1701         while (<$pipe>){
1702         print;
1703         $makeout .= $_;
1704     }
1705     $pipe->close;
1706     if ($?==0) {
1707          print "  $system -- OK\n";
1708          $self->{'install'} = "YES";
1709     } else {
1710          $self->{'install'} = "NO";
1711          print "  $system -- NOT OK\n";
1712          if ($makeout =~ /permission/s && $> > 0) {
1713              print "    You may have to su to root to install the package\n";
1714          }
1715     }
1716 }
1717
1718 #-> sub CPAN::Distribution::dir ;
1719 sub dir {
1720     shift->{'build_dir'};
1721 }
1722
1723 package CPAN::Bundle;
1724 @CPAN::Bundle::ISA = qw(CPAN::Debug CPAN::InfoObj CPAN::Module);
1725
1726 #-> sub CPAN::Bundle::as_string ;
1727 sub as_string {
1728     my($self) = @_;
1729     $self->contains;
1730     return $self->SUPER::as_string;
1731 }
1732
1733 #-> sub CPAN::Bundle::contains ;
1734 sub contains {
1735     my($self) = @_;
1736     my($parsefile) = $self->inst_file;
1737     unless ($parsefile) {
1738         # Try to get at it in the cpan directory
1739         $self->debug("no parsefile") if $CPAN::DEBUG;
1740         my $dist = $CPAN::META->instance('CPAN::Distribution',$self->{'CPAN_FILE'});
1741         $self->debug($dist->as_string) if $CPAN::DEBUG;
1742         $dist->get;
1743         $self->debug($dist->as_string) if $CPAN::DEBUG;
1744         my($todir) = $CPAN::META->catdir($CPAN::Config->{'cpan_home'},"Bundle");
1745         File::Path::mkpath($todir);
1746         my($me,$from,$to);
1747         ($me = $self->id) =~ s/.*://;
1748         $from = $CPAN::META->catfile($dist->{'build_dir'},"$me.pm");
1749         $to = $CPAN::META->catfile($todir,"$me.pm");
1750         File::Copy::copy($from, $to) or Carp::confess("Couldn't copy $from to $to: $!");
1751         $parsefile = $to;
1752     }
1753     my @result;
1754     my $fh = new IO::File;
1755     local $/ = "\n";
1756     open($fh,$parsefile) or die "Could not open '$parsefile': $!";
1757     my $inpod = 0;
1758     while (<$fh>) {
1759         $inpod = /^=(?!head1\s+CONTENTS)/ ? 0 : /^=head1\s+CONTENTS/ ? 1 : $inpod;
1760         next unless $inpod;
1761         next if /^=/;
1762         next if /^\s+$/;
1763         chomp;
1764         push @result, (split " ", $_, 2)[0];
1765     }
1766     close $fh;
1767     delete $self->{STATUS};
1768     $self->{CONTAINS} = [@result];
1769     @result;
1770 }
1771
1772 #-> sub CPAN::Bundle::inst_file ;
1773 sub inst_file {
1774     my($self) = @_;
1775     my($me,$inst_file);
1776     ($me = $self->id) =~ s/.*://;
1777     $inst_file = $CPAN::META->catfile($CPAN::Config->{'cpan_home'},"Bundle", "$me.pm");
1778     return $self->{'INST_FILE'} = $inst_file if -f $inst_file;
1779     $inst_file = $self->SUPER::inst_file;
1780     return $self->{'INST_FILE'} = $inst_file if -f $inst_file;
1781     return $self->{'INST_FILE'}; # even if undefined?
1782 }
1783
1784 #-> sub CPAN::Bundle::rematein ;
1785 sub rematein {
1786     my($self,$meth) = @_;
1787     $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
1788     my($s);
1789     for $s ($self->contains) {
1790         $CPAN::META->instance('CPAN::Module',$s)->$meth();
1791     }
1792 }
1793
1794 #-> sub CPAN::Bundle::force ;
1795 sub force   { shift->rematein('force',@_); }
1796 #-> sub CPAN::Bundle::install ;
1797 sub install { shift->rematein('install',@_); }
1798 #-> sub CPAN::Bundle::clean ;
1799 sub clean   { shift->rematein('clean',@_); }
1800 #-> sub CPAN::Bundle::test ;
1801 sub test    { shift->rematein('test',@_); }
1802 #-> sub CPAN::Bundle::make ;
1803 sub make    { shift->rematein('make',@_); }
1804
1805 # XXX not yet implemented!
1806 #-> sub CPAN::Bundle::readme ;
1807 sub readme  {
1808     my($self) = @_;
1809     my($file) = $self->cpan_file or print("No File found for bundle ", $self->id, "\n"), return;
1810     $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
1811     $CPAN::META->instance('CPAN::Distribution',$file)->readme;
1812 #    CPAN::FTP->localize("authors/id/$file",$index_wanted); # XXX
1813 }
1814
1815 package CPAN::Module;
1816 @CPAN::Module::ISA = qw(CPAN::Debug CPAN::InfoObj);
1817
1818 #-> sub CPAN::Module::as_glimpse ;
1819 sub as_glimpse {
1820     my($self) = @_;
1821     my(@m);
1822     my $class = ref($self);
1823     $class =~ s/^CPAN:://;
1824     push @m, sprintf "%-15s %-15s (%s)\n", $class, $self->{ID}, $self->cpan_file;
1825     join "", @m;
1826 }
1827
1828 #-> sub CPAN::Module::as_string ;
1829 sub as_string {
1830     my($self) = @_;
1831     my(@m);
1832     CPAN->debug($self) if $CPAN::DEBUG;
1833     my $class = ref($self);
1834     $class =~ s/^CPAN:://;
1835     local($^W) = 0;
1836     push @m, $class, " id = $self->{ID}\n";
1837     my $sprintf = "    %-12s %s\n";
1838     push @m, sprintf $sprintf, 'DESCRIPTION', $self->{description} if $self->{description};
1839     my $sprintf2 = "    %-12s %s (%s)\n";
1840     my($userid);
1841     if ($userid = $self->{'CPAN_USERID'} || $self->{'userid'}){
1842         push @m, sprintf(
1843                          $sprintf2,
1844                          'CPAN_USERID',
1845                          $userid,
1846                          $CPAN::META->instance(CPAN::Author,$userid)->fullname
1847                         )
1848     }
1849     push @m, sprintf $sprintf, 'CPAN_VERSION', $self->{CPAN_VERSION} if $self->{CPAN_VERSION};
1850     push @m, sprintf $sprintf, 'CPAN_FILE', $self->{CPAN_FILE} if $self->{CPAN_FILE};
1851     my $sprintf3 = "    %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
1852     my(%statd,%stats,%statl,%stati);
1853     @statd{qw,? i c a b R M S,} = qw,unknown idea pre-alpha alpha beta released mature standard,;
1854     @stats{qw,? m d u n,}       = qw,unknown mailing-list developer comp.lang.perl.* none,;
1855     @statl{qw,? p c + o,}       = qw,unknown perl C C++ other,;
1856     @stati{qw,? f r O,}         = qw,unknown functions references+ties object-oriented,;
1857     $statd{' '} = 'unknown';
1858     $stats{' '} = 'unknown';
1859     $statl{' '} = 'unknown';
1860     $stati{' '} = 'unknown';
1861     push @m, sprintf(
1862                      $sprintf3,
1863                      'DSLI_STATUS',
1864                      $self->{statd},
1865                      $self->{stats},
1866                      $self->{statl},
1867                      $self->{stati},
1868                      $statd{$self->{statd}},
1869                      $stats{$self->{stats}},
1870                      $statl{$self->{statl}},
1871                      $stati{$self->{stati}}
1872                     ) if $self->{statd};
1873     my $local_file = $self->inst_file;
1874     if ($local_file && ! exists $self->{MANPAGE}) {
1875         my $fh = IO::File->new($local_file) or Carp::croak("Couldn't open $local_file: $!");
1876         my $inpod = 0;
1877         my(@result);
1878         local $/ = "\n";
1879         while (<$fh>) {
1880             $inpod = /^=(?!head1\s+NAME)/ ? 0 : /^=head1\s+NAME/ ? 1 : $inpod;
1881             next unless $inpod;
1882             next if /^=/;
1883             next if /^\s+$/;
1884             chomp;
1885             push @result, $_;
1886         }
1887         close $fh;
1888         $self->{MANPAGE} = join " ", @result;
1889     }
1890     push @m, sprintf $sprintf, 'MANPAGE', $self->{MANPAGE} if $self->{MANPAGE};
1891     push @m, sprintf $sprintf, 'INST_FILE', $local_file || "(not installed)";
1892     push @m, sprintf $sprintf, 'INST_VERSION', $self->inst_version if $local_file;
1893     join "", @m, "\n";
1894 }
1895
1896 #-> sub CPAN::Module::cpan_file ;
1897 sub cpan_file    {
1898     my $self = shift;
1899     CPAN->debug($self->id) if $CPAN::DEBUG;
1900     unless (defined $self->{'CPAN_FILE'}) {
1901         CPAN::Index->reload;
1902     }
1903     if (defined $self->{'CPAN_FILE'}){
1904         return $self->{'CPAN_FILE'};
1905     } elsif (defined $self->{'userid'}) {
1906         return "Contact Author ".$self->{'userid'}."=".$CPAN::META->instance(CPAN::Author,$self->{'userid'})->fullname
1907     } else {
1908         return "N/A";
1909     }
1910 }
1911
1912 *name = \&cpan_file;
1913
1914 #-> sub CPAN::Module::cpan_version ;
1915 sub cpan_version { shift->{'CPAN_VERSION'} }
1916
1917 #-> sub CPAN::Module::force ;
1918 sub force {
1919     my($self) = @_;
1920     $self->{'force_update'}++;
1921 }
1922
1923 #-> sub CPAN::Module::rematein ;
1924 sub rematein {
1925     my($self,$meth) = @_;
1926     $self->debug($self->id) if $CPAN::DEBUG;
1927     my $cpan_file = $self->cpan_file;
1928     return if $cpan_file eq "N/A";
1929     return if $cpan_file =~ /^Contact Author/;
1930     my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1931     $pack->called_for($self->id);
1932     $pack->force if exists $self->{'force_update'};
1933     $pack->$meth();
1934     delete $self->{'force_update'};
1935 }
1936
1937 #-> sub CPAN::Module::readme ;
1938 sub readme { shift->rematein('readme') }
1939 #-> sub CPAN::Module::make ;
1940 sub make   { shift->rematein('make') }
1941 #-> sub CPAN::Module::clean ;
1942 sub clean  { shift->rematein('clean') }
1943 #-> sub CPAN::Module::test ;
1944 sub test   { shift->rematein('test') }
1945 #-> sub CPAN::Module::install ;
1946 sub install {
1947     my($self) = @_;
1948     my($doit) = 0;
1949     my($latest) = $self->cpan_version;
1950     $latest ||= 0;
1951     my($inst_file) = $self->inst_file;
1952     my($have) = 0;
1953     if (defined $inst_file) {
1954         $have = $self->inst_version;
1955     }
1956     if ($inst_file && $have >= $latest && not exists $self->{'force_update'}) {
1957         print $self->id, " is up to date.\n";
1958     } else {
1959         $doit = 1;
1960     }
1961     $self->rematein('install') if $doit;
1962 }
1963
1964 #-> sub CPAN::Module::inst_file ;
1965 sub inst_file {
1966     my($self) = @_;
1967     my($dir,@packpath);
1968     @packpath = split /::/, $self->{ID};
1969     $packpath[-1] .= ".pm";
1970     foreach $dir (@INC) {
1971         my $pmfile = CPAN->catfile($dir,@packpath);
1972         if (-f $pmfile){
1973             return $pmfile;
1974         }
1975     }
1976 }
1977
1978 #-> sub CPAN::Module::xs_file ;
1979 sub xs_file {
1980     my($self) = @_;
1981     my($dir,@packpath);
1982     @packpath = split /::/, $self->{ID};
1983     push @packpath, $packpath[-1];
1984     $packpath[-1] .= "." . $Config::Config{'dlext'};
1985     foreach $dir (@INC) {
1986         my $xsfile = CPAN->catfile($dir,'auto',@packpath);
1987         if (-f $xsfile){
1988             return $xsfile;
1989         }
1990     }
1991 }
1992
1993 #-> sub CPAN::Module::inst_version ;
1994 sub inst_version {
1995     my($self) = @_;
1996     my $parsefile = $self->inst_file or return 0;
1997     my $have = MY->parse_version($parsefile);
1998     $have ||= 0;
1999     $have =~ s/\s+//g;
2000     $have ||= 0;
2001     $have;
2002 }
2003
2004 package CPAN::CacheMgr;
2005 use vars qw($Du);
2006 @CPAN::CacheMgr::ISA = qw(CPAN::Debug CPAN::InfoObj);
2007 use File::Find;
2008
2009 #-> sub CPAN::CacheMgr::as_string ;
2010 sub as_string {
2011     eval { require Data::Dumper };
2012     if ($@) {
2013         return shift->SUPER::as_string;
2014     } else {
2015         return Data::Dumper::Dumper(shift);
2016     }
2017 }
2018
2019 #-> sub CPAN::CacheMgr::cachesize ;
2020 sub cachesize {
2021     shift->{DU};
2022 }
2023
2024 # sub check {
2025 #     my($self,@dirs) = @_;
2026 #     return unless -d $self->{ID};
2027 #     my $dir;
2028 #     @dirs = $self->dirs unless @dirs;
2029 #     for $dir (@dirs) {
2030 #         $self->disk_usage($dir);
2031 #     }
2032 # }
2033
2034 #-> sub CPAN::CacheMgr::clean_cache ;
2035 sub clean_cache {
2036     my $self = shift;
2037     my $dir;
2038     while ($self->{DU} > $self->{'MAX'} and $dir = shift @{$self->{FIFO}}) {
2039         $self->force_clean_cache($dir);
2040     }
2041     $self->debug("leaving clean_cache with $self->{DU}") if $CPAN::DEBUG;
2042 }
2043
2044 #-> sub CPAN::CacheMgr::dir ;
2045 sub dir {
2046     shift->{ID};
2047 }
2048
2049 #-> sub CPAN::CacheMgr::entries ;
2050 sub entries {
2051     my($self,$dir) = @_;
2052     $dir ||= $self->{ID};
2053     my($cwd) = Cwd::cwd();
2054     chdir $dir or Carp::croak("Can't chdir to $dir: $!");
2055     my $dh = DirHandle->new(".") or Carp::croak("Couldn't opendir $dir: $!");
2056     my(@entries);
2057     for ($dh->read) {
2058         next if $_ eq "." || $_ eq "..";
2059         if (-f $_) {
2060             push @entries, $CPAN::META->catfile($dir,$_);
2061         } elsif (-d _) {
2062             push @entries, $CPAN::META->catdir($dir,$_);
2063         } else {
2064             print STDERR "Warning: weird direntry in $dir: $_\n";
2065         }
2066     }
2067     chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
2068     sort {-M $b <=> -M $a} @entries;
2069 }
2070
2071 #-> sub CPAN::CacheMgr::disk_usage ;
2072 sub disk_usage {
2073     my($self,$dir) = @_;
2074     if (! defined $dir or $dir eq "") {
2075         $self->debug("Cannot determine disk usage for some reason") if $CPAN::DEBUG;
2076         return;
2077     }
2078     return if defined $self->{SIZE}{$dir};
2079     local($Du) = 0;
2080     find(
2081          sub {
2082              return if -l $_;
2083              $Du += -s;
2084          },
2085          $dir
2086         );
2087     $self->{SIZE}{$dir} = $Du/1024/1024;
2088     push @{$self->{FIFO}}, $dir;
2089     $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
2090     $self->{DU} += $Du/1024/1024;
2091     if ($self->{DU} > $self->{'MAX'} ) {
2092         printf "...Hold on a sec... CPAN's cleaning the cache: %.2f MB > %.2f MB\n",
2093                 $self->{DU}, $self->{'MAX'};
2094         $self->clean_cache;
2095     } else {
2096         $self->debug("NOT have to clean the cache: $self->{DU} <= $self->{'MAX'}") if $CPAN::DEBUG;
2097         $self->debug($self->as_string) if $CPAN::DEBUG;
2098     }
2099     $self->{DU};
2100 }
2101
2102 #-> sub CPAN::CacheMgr::force_clean_cache ;
2103 sub force_clean_cache {
2104     my($self,$dir) = @_;
2105     $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}") if $CPAN::DEBUG;
2106     File::Path::rmtree($dir);
2107     $self->{DU} -= $self->{SIZE}{$dir};
2108     delete $self->{SIZE}{$dir};
2109 }
2110
2111 #-> sub CPAN::CacheMgr::new ;
2112 sub new {
2113     my $class = shift;
2114     my $self = { ID => $CPAN::Config->{'build_dir'}, MAX => $CPAN::Config->{'build_cache'}, DU => 0 };
2115     File::Path::mkpath($self->{ID});
2116     my $dh = DirHandle->new($self->{ID});
2117     bless $self, $class;
2118     $self->debug("dir [$self->{ID}]") if $CPAN::DEBUG;
2119     my $e;
2120     for $e ($self->entries) {
2121         next if $e eq ".." || $e eq ".";
2122         $self->debug("Have to check size $e") if $CPAN::DEBUG;
2123         $self->disk_usage($e);
2124     }
2125     $self;
2126 }
2127
2128 package CPAN::Debug;
2129
2130 #-> sub CPAN::Debug::debug ;
2131 sub debug {
2132     my($self,$arg) = @_;
2133     my($caller,$func,$line,@rest) = caller(1); # caller(0) eg Complete, caller(1) eg readline
2134     ($caller) = caller(0);
2135     $caller =~ s/.*:://;
2136 #    print "caller[$caller]func[$func]line[$line]rest[@rest]\n";
2137 #    print "CPAN::DEBUG{caller}[$CPAN::DEBUG{$caller}]CPAN::DEBUG[$CPAN::DEBUG]\n";
2138     if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){
2139         if (ref $arg) {
2140             eval { require Data::Dumper };
2141             if ($@) {
2142                 print $arg->as_string;
2143             } else {
2144                 print Data::Dumper::Dumper($arg);
2145             }
2146         } else {
2147             print "Debug($caller:$func,$line,@rest): $arg\n"
2148         }
2149     }
2150 }
2151
2152 package CPAN::Config;
2153 import ExtUtils::MakeMaker 'neatvalue';
2154 use vars qw(%can);
2155
2156 %can = (
2157   'commit' => "Commit changes to disk",
2158   'defaults' => "Reload defaults from disk",
2159 );
2160
2161 #-> sub CPAN::Config::edit ;
2162 sub edit {
2163     my($class,@args) = @_;
2164     return unless @args;
2165     CPAN->debug("class[$class]args[".join(" | ",@args)."]");
2166     my($o,$str,$func,$args,$key_exists);
2167     $o = shift @args;
2168     if($can{$o}) {
2169         $class->$o(@args);
2170         return 1;
2171     } else {
2172         if (ref($CPAN::Config->{$o}) eq ARRAY) {
2173             $func = shift @args;
2174             # Let's avoid eval, it's easier to comprehend without.
2175             if ($func eq "push") {
2176                 push @{$CPAN::Config->{$o}}, @args;
2177             } elsif ($func eq "pop") {
2178                 pop @{$CPAN::Config->{$o}};
2179             } elsif ($func eq "shift") {
2180                 shift @{$CPAN::Config->{$o}};
2181             } elsif ($func eq "unshift") {
2182                 unshift @{$CPAN::Config->{$o}}, @args;
2183             } elsif ($func eq "splice") {
2184                 splice @{$CPAN::Config->{$o}}, @args;
2185             } else {
2186                 $CPAN::Config->{$o} = [@args];
2187             }
2188         } else {
2189             $CPAN::Config->{$o} = $args[0];
2190             print "    $o    ";
2191             print defined $CPAN::Config->{$o} ? $CPAN::Config->{$o} : "UNDEFINED";
2192         }
2193     }
2194 }
2195
2196 #-> sub CPAN::Config::commit ;
2197 sub commit {
2198     my($self, $configpm) = @_;
2199     my $mode;
2200     # mkpath!?
2201
2202     my($fh) = IO::File->new;
2203     $configpm ||= cfile();
2204     if (-f $configpm) {
2205         $mode = (stat $configpm)[2];
2206         if ($mode && ! -w _) {
2207             print "$configpm is not writable\n" and return;
2208         }
2209         #chmod 0644, $configpm; #?
2210     }
2211
2212     my $msg = <<EOF unless $configpm =~ /MyConfig/;
2213
2214 # This is CPAN.pm's systemwide configuration file.  This file provides
2215 # defaults for users, and the values can be changed in a per-user configuration
2216 # file. The user-config file is being looked for as ~/.cpan/CPAN/MyConfig.pm.
2217
2218 EOF
2219     $msg ||= "\n";
2220     open $fh, ">$configpm" or warn "Couldn't open >$configpm: $!";
2221     print $fh qq[$msg\$CPAN::Config = \{\n];
2222     foreach (sort keys %$CPAN::Config) {
2223         print $fh "  '$_' => ", ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}), ",\n";
2224     }
2225
2226     print $fh "};\n1;\n__END__\n";
2227     close $fh;
2228
2229     #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
2230     #chmod $mode, $configpm;
2231     $self->defaults;
2232     print "commit: wrote $configpm\n";
2233     1;
2234 }
2235
2236 *default = \&defaults;
2237 #-> sub CPAN::Config::defaults ;
2238 sub defaults {
2239     my($self) = @_;
2240     $self->unload;
2241     $self->load;
2242     1;
2243 }
2244
2245 my $dot_cpan;
2246 #-> sub CPAN::Config::load ;
2247 sub load {
2248     my($self) = @_;
2249     eval {require CPAN::Config;};       # We eval, because of some MakeMaker problems
2250     unshift @INC, $CPAN::META->catdir($ENV{HOME},".cpan") unless $dot_cpan++;
2251     eval {require CPAN::MyConfig;};     # where you can override system wide settings
2252     unless ( $self->load_succeeded ) {
2253           require CPAN::FirstTime;
2254           my($configpm,$fh);
2255           if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
2256               $configpm = $INC{"CPAN/Config.pm"};
2257           } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
2258               $configpm = $INC{"CPAN/MyConfig.pm"};
2259           } else {
2260               my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
2261               my($configpmdir) = MY->catdir($path_to_cpan,"CPAN");
2262               my($configpmtest) = MY->catfile($configpmdir,"Config.pm");
2263               if (-d $configpmdir || File::Path::mkpath($configpmdir)) {
2264 #_#_# following code dumped core on me with 5.003_11, a.k.
2265 #_#_#                  $fh = IO::File->new;
2266 #_#_#                  if ($fh->open(">$configpmtest")) {
2267 #_#_#                     $fh->print("1;\n");
2268 #_#_#                      $configpm = $configpmtest;
2269 #_#_#                  }
2270                   if (-w $configpmtest or -w $configpmdir) {
2271                       $configpm = $configpmtest;
2272                   }
2273               }
2274               unless ($configpm) {
2275                   $configpmdir = MY->catdir($ENV{HOME},".cpan","CPAN");
2276                   File::Path::mkpath($configpmdir);
2277                   $configpmtest = MY->catfile($configpmdir,"MyConfig.pm");
2278                   if (-w $configpmtest or -w $configpmdir) {
2279                       $configpm = $configpmtest;
2280                   } else {
2281                       warn "WARNING: CPAN.pm is unable to create a configuration file.\n";
2282                   }
2283               }
2284           }
2285           warn "Calling CPAN::FirstTime::init($configpm)";
2286           CPAN::FirstTime::init($configpm);
2287     }
2288 }
2289
2290 #-> sub CPAN::Config::load_succeeded ;
2291 sub load_succeeded {
2292     my($miss) = 0;
2293     for (qw(
2294             cpan_home keep_source_where build_dir build_cache index_expire
2295             gzip tar unzip make pager makepl_arg make_arg make_install_arg
2296             urllist inhibit_startup_message
2297            )) {
2298         $miss++ unless defined $CPAN::Config->{$_}; # we want them all
2299     }
2300     return !$miss;
2301 }
2302
2303 #-> sub CPAN::Config::unload ;
2304 sub unload {
2305     delete $INC{'CPAN/MyConfig.pm'};
2306     delete $INC{'CPAN/Config.pm'};
2307 }
2308
2309 #-> sub CPAN::Config::cfile ;
2310 sub cfile {
2311     $INC{'CPAN/MyConfig.pm'} || $INC{'CPAN/Config.pm'};
2312 }
2313
2314 *h = \&help;
2315 #-> sub CPAN::Config::help ;
2316 sub help {
2317     print <<EOF;
2318 Known options:
2319   defaults  reload default config values from disk
2320   commit    commit session changes to disk
2321
2322 You may edit key values in the follow fashion:
2323
2324   o conf build_cache 15
2325
2326   o conf build_dir "/foo/bar"
2327
2328   o conf urllist shift
2329
2330   o conf urllist unshift ftp://ftp.foo.bar/
2331
2332 EOF
2333     undef; #don't reprint CPAN::Config
2334 }
2335
2336 #-> sub CPAN::Config::complete ;
2337 sub complete {
2338     my($word,$line,$pos) = @_;
2339     $word ||= "";
2340     my(@words) = split " ", $line;
2341     my(@o_conf) = (sort keys %CPAN::Config::can, sort keys %$CPAN::Config);
2342     return (@o_conf) unless @words>2;
2343     if($words[2] =~ /->(.*)/) {
2344         my $meth = $1;
2345         my(@methods) = qw(shift unshift push pop splice);
2346         return @methods unless $meth;
2347         return sort grep /^\Q$meth\E/, @methods;
2348     }
2349     return sort grep /^\Q$word\E/, @o_conf;
2350 }
2351
2352 1;
2353
2354 =head1 NAME
2355
2356 CPAN - query, download and build perl modules from CPAN sites
2357
2358 =head1 SYNOPSIS
2359
2360 Interactive mode:
2361
2362   perl -MCPAN -e shell;
2363
2364 Batch mode:
2365
2366   use CPAN;
2367
2368   autobundle, clean, install, make, recompile, test
2369
2370 =head1 DESCRIPTION
2371
2372 The CPAN module is designed to automate the make and install of perl
2373 modules and extensions. It includes some searching capabilities as
2374 well knows a how to use Net::FTP or LWP to fetch the raw data from the
2375 net.
2376
2377 Modules are fetched from one or more of the mirrored CPAN
2378 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
2379 directory.
2380
2381 The CPAN module also supports the concept of named and versioned
2382 'bundles' of modules. Bundles simplify the handling of sets of
2383 related modules. See BUNDLES below.
2384
2385 The package contains a session manager and a cache manager. There is
2386 no status retained between sessions. The session manager keeps track
2387 of what has been fetched, built and installed in the current
2388 session. The cache manager keeps track of the disk space occupied by
2389 the make processes and deletes excess space in a simple FIFO style.
2390
2391 All methods provided are accessible in a programmer style and in an
2392 interactive shell style.
2393
2394 =head2 Interactive Mode
2395
2396 The interactive mode is entered by running
2397
2398     perl -MCPAN -e shell
2399
2400 which puts you into a readline interface. You will have most fun if
2401 you install Term::ReadKey and Term::ReadLine to enjoy both history and
2402 completion.
2403
2404 Once you are on the command line, type 'h' and the rest should be
2405 self-explanatory.
2406
2407 The most common uses of the interactive modes are
2408
2409 =over 2
2410
2411 =item Searching for authors, bundles, distribution files and modules
2412
2413 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
2414 for each of the four categories and another, C<i> for any of the other
2415 four. Each of the four entities is implemented as a class with
2416 slightly differing methods for displaying an object.
2417
2418 Arguments you pass to these commands are either strings matching exact
2419 the identification string of an object or regular expressions that are
2420 then matched case-insensitively against various attributes of the
2421 objects. The parser recognizes a regualar expression only if you
2422 enclose it between two slashes.
2423
2424 The principle is that the number of found objects influences how an
2425 item is displayed. If the search finds one item, we display the result
2426 of object-E<gt>as_string, but if we find more than one, we display
2427 each as object-E<gt>as_glimpse. E.g.
2428
2429     cpan> a ANDK
2430     Author id = ANDK
2431         EMAIL        a.koenig@franz.ww.TU-Berlin.DE
2432         FULLNAME     Andreas König
2433
2434
2435     cpan> a /andk/
2436     Author id = ANDK
2437         EMAIL        a.koenig@franz.ww.TU-Berlin.DE
2438         FULLNAME     Andreas König
2439
2440
2441     cpan> a /and.*rt/
2442     Author          ANDYD (Andy Dougherty)
2443     Author          MERLYN (Randal L. Schwartz)
2444
2445 =item make, test, install, clean modules or distributions
2446
2447 The four commands do indeed exist just as written above. Each of them
2448 takes as many arguments as provided and investigates for each what it
2449 might be. Is it a distribution file (recognized by embedded slashes),
2450 this file is being processed. Is it a module, CPAN determines the
2451 distribution file where this module is included and processes that.
2452
2453 Any C<make> and C<test> are run unconditionally. An C<install
2454 E<lt>distribution_fileE<gt>> also is run unconditionally.  But for
2455 C<install E<lt>module<gt>> CPAN checks if an install is actually
2456 needed for it and prints I<"Foo up to date"> in case the module
2457 doesnE<39>t need to be updated.
2458
2459 CPAN also keeps track of what it has done within the current session
2460 and doesnE<39>t try to build a package a second time regardless if it
2461 succeeded or not. The C<force > command takes as first argument the
2462 method to invoke (currently: make, test, or install) and executes the
2463 command from scratch.
2464
2465 Example:
2466
2467     cpan> install OpenGL
2468     OpenGL is up to date.
2469     cpan> force install OpenGL
2470     Running make
2471     OpenGL-0.4/
2472     OpenGL-0.4/COPYRIGHT
2473     [...]
2474
2475 =back
2476
2477 =head2 CPAN::Shell
2478
2479 The commands that are available in the shell interface are methods in
2480 the package CPAN::Shell. If you enter the shell command, all your
2481 input is split by the Text::ParseWords::shellwords() routine which
2482 acts like most shells do. The first word is being interpreted as the
2483 method to be called and the rest of the words are treated as arguments
2484 to this method.
2485
2486 =head2 ProgrammerE<39>s interface
2487
2488 If you do not enter the shell, the available shell commands are both
2489 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
2490 functions in the calling package (C<install(...)>). The
2491 programmerE<39>s interface has beta status. Do not heavily rely on it,
2492 changes may still happen.
2493
2494 =head2 Cache Manager
2495
2496 Currently the cache manager only keeps track of the build directory
2497 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
2498 deletes complete directories below build_dir as soon as the size of
2499 all directories there gets bigger than $CPAN::Config->{build_cache}
2500 (in MB). The contents of this cache may be used for later
2501 re-installations that you intend to do manually, but will never be
2502 trusted by CPAN itself. This is due to the fact that the user might
2503 use these directories for building modules on different architectures.
2504
2505 There is another directory ($CPAN::Config->{keep_source_where}) where
2506 the original distribution files are kept. This directory is not
2507 covered by the cache manager and must be controlled by the user. If
2508 you choose to have the same directory as build_dir and as
2509 keep_source_where directory, then your sources will be deleted with
2510 the same fifo mechanism.
2511
2512 =head2 Bundles
2513
2514 A bundle is just a perl module in the namespace Bundle:: that does not
2515 define any functions or methods. It usually only contains documentation.
2516
2517 It starts like a perl module with a package declaration and a $VERSION
2518 variable. After that the pod section looks like any other pod with the
2519 only difference, that I<one special pod section> exists starting with
2520 (verbatim):
2521
2522         =head1 CONTENTS
2523
2524 In this pod section each line obeys the format
2525
2526         Module_Name [Version_String] [- optional text]
2527
2528 The only required part is the first field, the name of a module
2529 (eg. Foo::Bar, ie. I<not> the name of the distribution file). The rest
2530 of the line is optional. The comment part is delimited by a dash just
2531 as in the man page header.
2532
2533 The distribution of a bundle should follow the same convention as
2534 other distributions. The bundle() function in the CPAN module simply
2535 parses the module that defines the bundle and returns the module names
2536 that are listed in the described CONTENTS section.
2537
2538 Bundles are treated specially in the CPAN package. If you say 'install
2539 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
2540 the modules in the CONTENTS section of the pod.  You can install your
2541 own Bundles locally by placing a conformant Bundle file somewhere into
2542 your @INC path. The autobundle() command which is available in the
2543 shell interface does that for you by including all currently installed
2544 modules in a snapshot bundle file.
2545
2546 There is a meaningless Bundle::Demo available on CPAN. Try to install
2547 it, it usually does no harm, just demonstrates what the Bundle
2548 interface looks like.
2549
2550 =head2 autobundle
2551
2552 C<autobundle> writes a bundle file into the
2553 C<$CPAN::Config->{cpan_home}/Bundle> directory. The file contains a list
2554 of all modules that are both available from CPAN and currently
2555 installed within @INC. The name of the bundle file is based on the
2556 current date and a counter.
2557
2558 =head2 recompile
2559
2560 recompile() is a very special command in that it takes no argument and
2561 runs the make/test/install cycle with brute force over all installed
2562 dynamically loadable extensions (aka XS modules) with 'force' in
2563 effect. Primary purpose of this command is to act as a rescue in case
2564 your perl breaks binary compatibility. If one of the modules that CPAN
2565 uses is in turn depending on binary compatibility (so you cannot run
2566 CPAN commands), then you should try the CPAN::Nox module for recovery.
2567
2568 A very popular use for recompile is to finish a network
2569 installation. Imagine, you have a common source tree for two different
2570 architectures. You decide to do a completely independent fresh
2571 installation. You start on one architecture with the help of a Bundle
2572 file produced earlier. CPAN installs the whole Bundle for you, but
2573 when you try to repeat the job on the second architecture, CPAN
2574 responds with a C<"Foo up to date"> message for all modules. So you
2575 will be glad to run recompile in the second architecture and
2576 youE<39>re done.
2577
2578 =head1 CONFIGURATION
2579
2580 When the CPAN module is installed a site wide configuration file is
2581 created as CPAN/Config.pm. The default values defined there can be
2582 overridden in another configuration file: CPAN/MyConfig.pm. You can
2583 store this file in $HOME/.cpan/CPAN/MyConfig.pm if you want, because
2584 $HOME/.cpan is added to the search path of the CPAN module before the
2585 use() or require() statements.
2586
2587 Currently the following keys in the hash reference $CPAN::Config are
2588 defined:
2589
2590   build_cache       size of cache for directories to build modules
2591   build_dir         locally accessible directory to build modules
2592   index_expire      after how many days refetch index files
2593   cpan_home         local directory reserved for this package
2594   gzip              location of external program gzip
2595   inhibit_startup_message
2596                     if true, does not print the startup message
2597   keep_source       keep the source in a local directory?
2598   keep_source_where where keep the source (if we do)
2599   make              location of external program make
2600   make_arg          arguments that should always be passed to 'make'
2601   make_install_arg  same as make_arg for 'make install'
2602   makepl_arg        arguments passed to 'perl Makefile.PL'
2603   pager             location of external program more (or any pager)
2604   tar               location of external program tar
2605   unzip             location of external program unzip
2606   urllist           arrayref to nearby CPAN sites (or equivalent locations)
2607
2608 You can set and query each of these options interactively in the cpan
2609 shell with the command set defined within the C<o conf> command:
2610
2611 =over 2
2612
2613 =item o conf E<lt>scalar optionE<gt>
2614
2615 prints the current value of the I<scalar option>
2616
2617 =item o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>
2618
2619 Sets the value of the I<scalar option> to I<value>
2620
2621 =item o conf E<lt>list optionE<gt>
2622
2623 prints the current value of the I<list option> in MakeMaker's
2624 neatvalue format.
2625
2626 =item o conf E<lt>list optionE<gt> [shift|pop]
2627
2628 shifts or pops the array in the I<list option> variable
2629
2630 =item o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>
2631
2632 works like the corresponding perl commands. Whitespace is used to
2633 determine the arguments.
2634
2635 =back
2636
2637 =head1 SECURITY
2638
2639 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
2640 install foreign, unmasked, unsigned code on your machine. We compare
2641 to a checksum that comes from the net just as the distribution file
2642 itself. If somebody has managed to tamper with the distribution file,
2643 they may have as well tampered with the CHECKSUMS file. Future
2644 development will go towards stong authentification.
2645
2646 =head1 EXPORT
2647
2648 Most functions in package CPAN are exported per default. The reason
2649 for this is that the primary use is intended for the cpan shell or for
2650 oneliners.
2651
2652 =head1 Debugging
2653
2654 The debugging of this module is pretty difficult, because we have
2655 interferences of the software producing the indices on CPAN, of the
2656 mirroring process on CPAN, of packaging, of configuration, of
2657 synchronicity, and of bugs within CPAN.pm.
2658
2659 In interactive mode you can try "o debug" which will list options for
2660 debugging the various parts of the package. The output may not be very
2661 useful for you as it's just a byproduct of my own testing, but if you
2662 have an idea which part of the package may have a bug, it's sometimes
2663 worth to give it a try and send me more specific output. You should
2664 know that "o debug" has built-in completion support.
2665
2666 =head2 Prerequisites
2667
2668 If you have a local mirror of CPAN and can access all files with
2669 "file:" URLs, then you only need perl5.003 to run this
2670 module. Otherwise you need Net::FTP intalled. LWP may be required for
2671 non-UNIX systems or if your nearest CPAN site is associated with an
2672 URL that is not C<ftp:>.
2673
2674 This module presumes that all packages on CPAN
2675
2676 =over 2
2677
2678 =item *
2679
2680 declare their $VERSION variable in an easy to parse manner. This
2681 prerequisite can hardly be relaxed because it consumes by far too much
2682 memory to load all packages into the running program just to determine
2683 the $VERSION variable . Currently all programs that are dealing with
2684 VERSION use something like this
2685
2686     perl -MExtUtils::MakeMaker -le \
2687         'print MM->parse_version($ARGV[0])' filename
2688
2689 If you are author of a package and wonder if your VERSION can be
2690 parsed, please try the above method.
2691
2692 =item *
2693
2694 come as compressed or gzipped tarfiles or as zip files and contain a
2695 Makefile.PL (well we try to handle a bit more, but without much
2696 enthusiasm).
2697
2698 =back
2699
2700 =head1 AUTHOR
2701
2702 Andreas König E<lt>a.koenig@mind.deE<gt>
2703
2704 =head1 SEE ALSO
2705
2706 perl(1), CPAN::Nox(3)
2707
2708 =cut
2709