lib/CPAN.pm

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