lib/CPAN.pm

   1 package CPAN;
   2 use vars qw{$Try_autoload $Revision
   3             $META $Signal $Cwd $End
   4             $Suppress_readline %Dontload
   5             $Frontend  $Defaultsite
   6            };
   7
   8 $VERSION = '1.44_54';
   9
  10 # $Id: CPAN.pm,v 1.250 1999/01/14 12:26:13 k Exp $
  11
  12 # only used during development:
  13 $Revision = "";
  14 # $Revision = "[".substr(q$Revision: 1.250 $, 10)."]";
  15
  16 use Carp ();
  17 use Config ();
  18 use Cwd ();
  19 use DirHandle;
  20 use Exporter ();
  21 use ExtUtils::MakeMaker (); # $SelfLoader::DEBUG=1;
  22 use File::Basename ();
  23 use File::Copy ();
  24 use File::Find;
  25 use File::Path ();
  26 use FileHandle ();
  27 use Safe ();
  28 use Text::ParseWords ();
  29 use Text::Wrap;
  30
  31 END { $End++; &cleanup; }
  32
  33 %CPAN::DEBUG = qw[
  34                   CPAN              1
  35                   Index             2
  36                   InfoObj           4
  37                   Author            8
  38                   Distribution     16
  39                   Bundle           32
  40                   Module           64
  41                   CacheMgr        128
  42                   Complete        256
  43                   FTP             512
  44                   Shell          1024
  45                   Eval           2048
  46                   Config         4096
  47                   Tarzip         8192
  48 ];
  49
  50 $CPAN::DEBUG ||= 0;
  51 $CPAN::Signal ||= 0;
  52 $CPAN::Frontend ||= "CPAN::Shell";
  53 $CPAN::Defaultsite ||= "ftp://ftp.perl.org/pub/CPAN";
  54
  55 package CPAN;
  56 use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $term);
  57 use strict qw(vars);
  58
  59 @CPAN::ISA = qw(CPAN::Debug Exporter);
  60
  61 @EXPORT = qw(
  62              autobundle bundle expand force get
  63              install make readme recompile shell test clean
  64             );
  65
  66 #-> sub CPAN::AUTOLOAD ;
  67 sub AUTOLOAD {
  68     my($l) = $AUTOLOAD;
  69     $l =~ s/.*:://;
  70     my(%EXPORT);
  71     @EXPORT{@EXPORT} = '';
  72     if (exists $EXPORT{$l}){
  73         CPAN::Shell->$l(@_);
  74     } else {
  75         my $ok = CPAN::Shell->try_dot_al($AUTOLOAD);
  76         if ($ok) {
  77             goto &$AUTOLOAD;
  78 #       } else {
  79 #           $CPAN::Frontend->mywarn("Could not autoload $AUTOLOAD");
  80         }
  81         $CPAN::Frontend->mywarn(qq{Unknown command "$AUTOLOAD". }.
  82                                 qq{Type ? for help.
  83 });
  84     }
  85 }
  86
  87 #-> sub CPAN::shell ;
  88 sub shell {
  89     $Suppress_readline ||= ! -t STDIN;
  90
  91     my $prompt = "cpan> ";
  92     local($^W) = 1;
  93     unless ($Suppress_readline) {
  94         require Term::ReadLine;
  95 #       import Term::ReadLine;
  96         $term = Term::ReadLine->new('CPAN Monitor');
  97         $readline::rl_completion_function =
  98             $readline::rl_completion_function = 'CPAN::Complete::cpl';
  99     }
 100
 101     no strict;
 102     $META->checklock();
 103     my $getcwd;
 104     $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
 105     my $cwd = CPAN->$getcwd();
 106     my $rl_avail = $Suppress_readline ? "suppressed" :
 107         ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
 108             "available (try ``install Bundle::CPAN'')";
 109
 110     $CPAN::Frontend->myprint(
 111                              qq{
 112 cpan shell -- CPAN exploration and modules installation (v$CPAN::VERSION$CPAN::Revision)
 113 ReadLine support $rl_avail
 114
 115 }) unless $CPAN::Config->{'inhibit_startup_message'} ;
 116     my($continuation) = "";
 117     while () {
 118         if ($Suppress_readline) {
 119             print $prompt;
 120             last unless defined ($_ = <> );
 121             chomp;
 122         } else {
 123             last unless defined ($_ = $term->readline($prompt));
 124         }
 125         $_ = "$continuation$_" if $continuation;
 126         s/^\s+//;
 127         next if /^$/;
 128         $_ = 'h' if /^\s*\?/;
 129         if (/^(?:q(?:uit)?|bye|exit)$/i) {
 130             last;
 131         } elsif (s/\\$//s) {
 132             chomp;
 133             $continuation = $_;
 134             $prompt = "    > ";
 135         } elsif (/^\!/) {
 136             s/^\!//;
 137             my($eval) = $_;
 138             package CPAN::Eval;
 139             use vars qw($import_done);
 140             CPAN->import(':DEFAULT') unless $import_done++;
 141             CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
 142             eval($eval);
 143             warn $@ if $@;
 144             $continuation = "";
 145             $prompt = "cpan> ";
 146         } elsif (/./) {
 147             my(@line);
 148             if ($] < 5.00322) { # parsewords had a bug until recently
 149                 @line = split;
 150             } else {
 151                 eval { @line = Text::ParseWords::shellwords($_) };
 152                 warn($@), next if $@;
 153             }
 154             $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
 155             my $command = shift @line;
 156             eval { CPAN::Shell->$command(@line) };
 157             warn $@ if $@;
 158             chdir $cwd;
 159             $CPAN::Frontend->myprint("\n");
 160             $continuation = "";
 161             $prompt = "cpan> ";
 162         }
 163     } continue {
 164       $Signal=0;
 165     }
 166 }
 167
 168 package CPAN::CacheMgr;
 169 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
 170 use File::Find;
 171
 172 package CPAN::Config;
 173 import ExtUtils::MakeMaker 'neatvalue';
 174 use vars qw(%can $dot_cpan);
 175
 176 %can = (
 177   'commit' => "Commit changes to disk",
 178   'defaults' => "Reload defaults from disk",
 179   'init'   => "Interactive setting of all options",
 180 );
 181
 182 package CPAN::FTP;
 183 use vars qw($Ua $Thesite $Themethod);
 184 @CPAN::FTP::ISA = qw(CPAN::Debug);
 185
 186 package CPAN::Complete;
 187 @CPAN::Complete::ISA = qw(CPAN::Debug);
 188
 189 package CPAN::Index;
 190 use vars qw($last_time $date_of_03);
 191 @CPAN::Index::ISA = qw(CPAN::Debug);
 192 $last_time ||= 0;
 193 $date_of_03 ||= 0;
 194
 195 package CPAN::InfoObj;
 196 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
 197
 198 package CPAN::Author;
 199 @CPAN::Author::ISA = qw(CPAN::InfoObj);
 200
 201 package CPAN::Distribution;
 202 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
 203
 204 package CPAN::Bundle;
 205 @CPAN::Bundle::ISA = qw(CPAN::Module);
 206
 207 package CPAN::Module;
 208 @CPAN::Module::ISA = qw(CPAN::InfoObj);
 209
 210 package CPAN::Shell;
 211 use vars qw($AUTOLOAD $redef @ISA);
 212 @CPAN::Shell::ISA = qw(CPAN::Debug);
 213
 214 #-> sub CPAN::Shell::AUTOLOAD ;
 215 sub AUTOLOAD {
 216     my($autoload) = $AUTOLOAD;
 217     my $class = shift(@_);
 218     # warn "autoload[$autoload] class[$class]";
 219     $autoload =~ s/.*:://;
 220     if ($autoload =~ /^w/) {
 221         if ($CPAN::META->has_inst('CPAN::WAIT')) {
 222             CPAN::WAIT->$autoload(@_);
 223         } else {
 224             $CPAN::Frontend->mywarn(qq{
 225 Commands starting with "w" require CPAN::WAIT to be installed.
 226 Please consider installing CPAN::WAIT to use the fulltext index.
 227 For this you just need to type
 228     install CPAN::WAIT
 229 });
 230         }
 231     } else {
 232         my $ok = CPAN::Shell->try_dot_al($AUTOLOAD);
 233         if ($ok) {
 234             goto &$AUTOLOAD;
 235 #       } else {
 236 #           $CPAN::Frontend->mywarn("Could not autoload $autoload");
 237         }
 238         $CPAN::Frontend->mywarn(qq{Unknown command '$autoload'. }.
 239                                 qq{Type ? for help.
 240 });
 241     }
 242 }
 243
 244 #-> CPAN::Shell::try_dot_al
 245 sub try_dot_al {
 246     my($class,$autoload) = @_;
 247     return unless $CPAN::Try_autoload;
 248     # I don't see how to re-use that from the AutoLoader...
 249     my($name,$ok);
 250     # Braces used to preserve $1 et al.
 251     {
 252         my ($pkg,$func) = $autoload =~ /(.*)::([^:]+)$/;
 253         $pkg =~ s|::|/|g;
 254         if (defined($name=$INC{"$pkg.pm"}))
 255             {
 256                 $name =~ s|^(.*)$pkg\.pm$|$1auto/$pkg/$func.al|;
 257                 $name = undef unless (-r $name);
 258             }
 259         unless (defined $name)
 260             {
 261                 $name = "auto/$autoload.al";
 262                 $name =~ s|::|/|g;
 263             }
 264     }
 265     my $save = $@;
 266     eval {local $SIG{__DIE__};require $name};
 267     if ($@) {
 268         if (substr($autoload,-9) eq '::DESTROY') {
 269             *$autoload = sub {};
 270             $ok = 1;
 271         } else {
 272             if ($name =~ s{(\w{12,})\.al$}{substr($1,0,11).".al"}e){
 273                 eval {local $SIG{__DIE__};require $name};
 274             }
 275             if ($@){
 276                 $@ =~ s/ at .*\n//;
 277                 Carp::croak $@;
 278             } else {
 279                 $ok = 1;
 280             }
 281         }
 282     } else {
 283
 284         $ok = 1;
 285
 286     }
 287     $@ = $save;
 288 #    my $lm = Carp::longmess();
 289 #    warn "ok[$ok] autoload[$autoload] longmess[$lm]"; # debug
 290     return $ok;
 291 }
 292
 293 #### autoloader is experimental
 294 #### to try it we have to set $Try_autoload and uncomment
 295 #### the use statement and uncomment the __END__ below
 296 #### You also need AutoSplit 1.01 available. MakeMaker will
 297 #### then build CPAN with all the AutoLoad stuff.
 298 # use AutoLoader;
 299 # $Try_autoload = 1;
 300
 301 if ($CPAN::Try_autoload) {
 302     my $p;
 303     for $p (qw(
 304                CPAN::Author CPAN::Bundle CPAN::CacheMgr CPAN::Complete
 305                CPAN::Config CPAN::Debug CPAN::Distribution CPAN::FTP
 306                CPAN::FTP::netrc CPAN::Index CPAN::InfoObj CPAN::Module
 307                  )) {
 308         *{"$p\::AUTOLOAD"} = \&AutoLoader::AUTOLOAD;
 309     }
 310 }
 311
 312 package CPAN::Tarzip;
 313 use vars qw($AUTOLOAD @ISA);
 314 @CPAN::Tarzip::ISA = qw(CPAN::Debug);
 315
 316 package CPAN::Queue;
 317 # currently only used to determine if we should or shouldn't announce
 318 # the availability of a new CPAN module
 319
 320 # but now we try to use it for dependency tracking. For that to happen
 321 # we need to draw a dependency tree and do the leaves first. This can
 322 # easily be reached by running CPAN.pm recursively, but we don't want
 323 # to waste memory and run into deep recursion. So what we can do is
 324 # this: run the queue as the user suggested. When a dependency is
 325 # detected check if it is in the queue. If so, rearrange, otherwise
 326 # unshift it on the queue.
 327
 328 use vars qw{ @All };
 329
 330 sub new {
 331   my($class,$mod) = @_;
 332   my $self = bless {mod => $mod}, $class;
 333   push @All, $self;
 334   # my @all = map { $_->{mod} } @All;
 335   # warn "Adding Queue object for mod[$mod] all[@all]";
 336   return $self;
 337
 338 }
 339
 340 sub first {
 341   my $obj = $All[0];
 342   $obj->{mod};
 343 }
 344
 345 sub delete_first {
 346   my($class,$what) = @_;
 347   my $i;
 348   for my $i (0..$#All) {
 349     if (  $All[$i]->{mod} eq $what ) {
 350       splice @All, $i, 1;
 351       return;
 352     }
 353   }
 354 }
 355
 356 sub jumpqueue {
 357   my $class = shift;
 358   my @what = @_;
 359   my $obj;
 360   WHAT: for my $what (reverse @what) {
 361     my $jumped = 0;
 362     for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
 363       if ($All[$i]->{mod} eq $what){
 364         $jumped++;
 365         if ($jumped > 100) { # one's OK if e.g. just processing now;
 366                              # more are OK if user typed it several
 367                              # times
 368           $CPAN::Frontend->mywarn(
 369 qq{Object [$what] queued more than 100 times, ignoring}
 370                                  );
 371           next WHAT;
 372         }
 373       }
 374     }
 375     my $obj = bless { mod => $what }, $class;
 376     unshift @All, $obj;
 377   }
 378 }
 379
 380 sub exists {
 381   my($self,$what) = @_;
 382   my @all = map { $_->{mod} } @All;
 383   my $exists = grep { $_->{mod} eq $what } @All;
 384   # warn "Checking exists in Queue object for mod[$what] all[@all] exists[$exists]";
 385   $exists;
 386 }
 387
 388 sub delete {
 389   my($self,$mod) = @_;
 390   @All = grep { $_->{mod} ne $mod } @All;
 391   # my @all = map { $_->{mod} } @All;
 392   # warn "Deleting Queue object for mod[$mod] all[@all]";
 393 }
 394
 395 package CPAN;
 396
 397 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
 398
 399 # Do this after you have set up the whole inheritance
 400 CPAN::Config->load unless defined $CPAN::No_Config_is_ok;
 401
 402 1;
 403
 404 # __END__ # uncomment this and AutoSplit version 1.01 will split it
 405
 406 #-> sub CPAN::autobundle ;
 407 sub autobundle;
 408 #-> sub CPAN::bundle ;
 409 sub bundle;
 410 #-> sub CPAN::expand ;
 411 sub expand;
 412 #-> sub CPAN::force ;
 413 sub force;
 414 #-> sub CPAN::install ;
 415 sub install;
 416 #-> sub CPAN::make ;
 417 sub make;
 418 #-> sub CPAN::clean ;
 419 sub clean;
 420 #-> sub CPAN::test ;
 421 sub test;
 422
 423 #-> sub CPAN::all ;
 424 sub all {
 425     my($mgr,$class) = @_;
 426     CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
 427     CPAN::Index->reload;
 428     values %{ $META->{$class} };
 429 }
 430
 431 # Called by shell, not in batch mode. Not clean XXX
 432 #-> sub CPAN::checklock ;
 433 sub checklock {
 434     my($self) = @_;
 435     my $lockfile = MM->catfile($CPAN::Config->{cpan_home},".lock");
 436     if (-f $lockfile && -M _ > 0) {
 437         my $fh = FileHandle->new($lockfile);
 438         my $other = <$fh>;
 439         $fh->close;
 440         if (defined $other && $other) {
 441             chomp $other;
 442             return if $$==$other; # should never happen
 443             $CPAN::Frontend->mywarn(
 444                                     qq{
 445 There seems to be running another CPAN process ($other). Contacting...
 446 });
 447             if (kill 0, $other) {
 448                 $CPAN::Frontend->mydie(qq{Other job is running.
 449 You may want to kill it and delete the lockfile, maybe. On UNIX try:
 450     kill $other
 451     rm $lockfile
 452 });
 453             } elsif (-w $lockfile) {
 454                 my($ans) =
 455                     ExtUtils::MakeMaker::prompt
 456                         (qq{Other job not responding. Shall I overwrite }.
 457                          qq{the lockfile? (Y/N)},"y");
 458                 $CPAN::Frontend->myexit("Ok, bye\n")
 459                     unless $ans =~ /^y/i;
 460             } else {
 461                 Carp::croak(
 462                             qq{Lockfile $lockfile not writeable by you. }.
 463                             qq{Cannot proceed.\n}.
 464                             qq{    On UNIX try:\n}.
 465                             qq{    rm $lockfile\n}.
 466                             qq{  and then rerun us.\n}
 467                            );
 468             }
 469         }
 470     }
 471     File::Path::mkpath($CPAN::Config->{cpan_home});
 472     my $fh;
 473     unless ($fh = FileHandle->new(">$lockfile")) {
 474         if ($! =~ /Permission/) {
 475             my $incc = $INC{'CPAN/Config.pm'};
 476             my $myincc = MM->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm');
 477             $CPAN::Frontend->myprint(qq{
 478
 479 Your configuration suggests that CPAN.pm should use a working
 480 directory of
 481     $CPAN::Config->{cpan_home}
 482 Unfortunately we could not create the lock file
 483     $lockfile
 484 due to permission problems.
 485
 486 Please make sure that the configuration variable
 487     \$CPAN::Config->{cpan_home}
 488 points to a directory where you can write a .lock file. You can set
 489 this variable in either
 490     $incc
 491 or
 492     $myincc
 493
 494 });
 495         }
 496         $CPAN::Frontend->mydie("Could not open >$lockfile: $!");
 497     }
 498     $fh->print($$, "\n");
 499     $self->{LOCK} = $lockfile;
 500     $fh->close;
 501     $SIG{'TERM'} = sub {
 502       &cleanup;
 503       $CPAN::Frontend->mydie("Got SIGTERM, leaving");
 504     };
 505     $SIG{'INT'} = sub {
 506       # no blocks!!!
 507       &cleanup if $Signal;
 508       $CPAN::Frontend->mydie("Got another SIGINT") if $Signal;
 509       print "Caught SIGINT\n";
 510       $Signal++;
 511     };
 512     $SIG{'__DIE__'} = \&cleanup;
 513     $self->debug("Signal handler set.") if $CPAN::DEBUG;
 514 }
 515
 516 #-> sub CPAN::DESTROY ;
 517 sub DESTROY {
 518     &cleanup; # need an eval?
 519 }
 520
 521 #-> sub CPAN::cwd ;
 522 sub cwd {Cwd::cwd();}
 523
 524 #-> sub CPAN::getcwd ;
 525 sub getcwd {Cwd::getcwd();}
 526
 527 #-> sub CPAN::exists ;
 528 sub exists {
 529     my($mgr,$class,$id) = @_;
 530     CPAN::Index->reload;
 531     ### Carp::croak "exists called without class argument" unless $class;
 532     $id ||= "";
 533     exists $META->{$class}{$id};
 534 }
 535
 536 #-> sub CPAN::delete ;
 537 sub delete {
 538   my($mgr,$class,$id) = @_;
 539   delete $META->{$class}{$id};
 540 }
 541
 542 #-> sub CPAN::has_inst
 543 sub has_inst {
 544     my($self,$mod,$message) = @_;
 545     Carp::croak("CPAN->has_inst() called without an argument")
 546         unless defined $mod;
 547     if (defined $message && $message eq "no") {
 548         $Dontload{$mod}||=1;
 549         return 0;
 550     } elsif (exists $Dontload{$mod}) {
 551         return 0;
 552     }
 553     my $file = $mod;
 554     my $obj;
 555     $file =~ s|::|/|g;
 556     $file =~ s|/|\\|g if $^O eq 'MSWin32';
 557     $file .= ".pm";
 558     if ($INC{$file}) {
 559 #       warn "$file in %INC"; #debug
 560         return 1;
 561     } elsif (eval { require $file }) {
 562         # eval is good: if we haven't yet read the database it's
 563         # perfect and if we have installed the module in the meantime,
 564         # it tries again. The second require is only a NOOP returning
 565         # 1 if we had success, otherwise it's retrying
 566         $CPAN::Frontend->myprint("CPAN: $mod loaded ok\n");
 567         if ($mod eq "CPAN::WAIT") {
 568             push @CPAN::Shell::ISA, CPAN::WAIT;
 569         }
 570         return 1;
 571     } elsif ($mod eq "Net::FTP") {
 572         warn qq{
 573   Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
 574   if you just type
 575       install Bundle::libnet
 576
 577 };
 578         sleep 2;
 579     } elsif ($mod eq "MD5"){
 580         $CPAN::Frontend->myprint(qq{
 581   CPAN: MD5 security checks disabled because MD5 not installed.
 582   Please consider installing the MD5 module.
 583
 584 });
 585         sleep 2;
 586     }
 587     return 0;
 588 }
 589
 590 #-> sub CPAN::instance ;
 591 sub instance {
 592     my($mgr,$class,$id) = @_;
 593     CPAN::Index->reload;
 594     $id ||= "";
 595     $META->{$class}{$id} ||= $class->new(ID => $id );
 596 }
 597
 598 #-> sub CPAN::new ;
 599 sub new {
 600     bless {}, shift;
 601 }
 602
 603 #-> sub CPAN::cleanup ;
 604 sub cleanup {
 605   # warn "cleanup called with arg[@_] End[$End] Signal[$Signal]";
 606   local $SIG{__DIE__} = '';
 607   my($message) = @_;
 608   my $i = 0;
 609   my $ineval = 0;
 610   if (
 611       0 &&           # disabled, try reload cpan with it
 612       $] > 5.004_60  # thereabouts
 613      ) {
 614     $ineval = $^S;
 615   } else {
 616     my($subroutine);
 617     while ((undef,undef,undef,$subroutine) = caller(++$i)) {
 618       $ineval = 1, last if
 619           $subroutine eq '(eval)';
 620     }
 621   }
 622   return if $ineval && !$End;
 623   return unless defined $META->{'LOCK'};
 624   return unless -f $META->{'LOCK'};
 625   unlink $META->{'LOCK'};
 626   # require Carp;
 627   # Carp::cluck("DEBUGGING");
 628   $CPAN::Frontend->mywarn("Lockfile removed.\n");
 629 }
 630
 631 package CPAN::CacheMgr;
 632
 633 #-> sub CPAN::CacheMgr::as_string ;
 634 sub as_string {
 635     eval { require Data::Dumper };
 636     if ($@) {
 637         return shift->SUPER::as_string;
 638     } else {
 639         return Data::Dumper::Dumper(shift);
 640     }
 641 }
 642
 643 #-> sub CPAN::CacheMgr::cachesize ;
 644 sub cachesize {
 645     shift->{DU};
 646 }
 647
 648 sub tidyup {
 649   my($self) = @_;
 650   return unless -d $self->{ID};
 651   while ($self->{DU} > $self->{'MAX'} ) {
 652     my($toremove) = shift @{$self->{FIFO}};
 653     $CPAN::Frontend->myprint(sprintf(
 654                                      "Deleting from cache".
 655                                      ": $toremove (%.1f>%.1f MB)\n",
 656                                      $self->{DU}, $self->{'MAX'})
 657                             );
 658     return if $CPAN::Signal;
 659     $self->force_clean_cache($toremove);
 660     return if $CPAN::Signal;
 661   }
 662 }
 663
 664 #-> sub CPAN::CacheMgr::dir ;
 665 sub dir {
 666     shift->{ID};
 667 }
 668
 669 #-> sub CPAN::CacheMgr::entries ;
 670 sub entries {
 671     my($self,$dir) = @_;
 672     return unless defined $dir;
 673     $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
 674     $dir ||= $self->{ID};
 675     my $getcwd;
 676     $getcwd  = $CPAN::Config->{'getcwd'} || 'cwd';
 677     my($cwd) = CPAN->$getcwd();
 678     chdir $dir or Carp::croak("Can't chdir to $dir: $!");
 679     my $dh = DirHandle->new(".") or Carp::croak("Couldn't opendir $dir: $!");
 680     my(@entries);
 681     for ($dh->read) {
 682         next if $_ eq "." || $_ eq "..";
 683         if (-f $_) {
 684             push @entries, MM->catfile($dir,$_);
 685         } elsif (-d _) {
 686             push @entries, MM->catdir($dir,$_);
 687         } else {
 688             $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
 689         }
 690     }
 691     chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
 692     sort { -M $b <=> -M $a} @entries;
 693 }
 694
 695 #-> sub CPAN::CacheMgr::disk_usage ;
 696 sub disk_usage {
 697     my($self,$dir) = @_;
 698     return if exists $self->{SIZE}{$dir};
 699     return if $CPAN::Signal;
 700     my($Du) = 0;
 701     find(
 702          sub {
 703              $File::Find::prune++ if $CPAN::Signal;
 704              return if -l $_;
 705              $Du += (-s _); # parens to help cperl-mode
 706          },
 707          $dir
 708         );
 709     return if $CPAN::Signal;
 710     $self->{SIZE}{$dir} = $Du/1024/1024;
 711     push @{$self->{FIFO}}, $dir;
 712     $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
 713     $self->{DU} += $Du/1024/1024;
 714     $self->{DU};
 715 }
 716
 717 #-> sub CPAN::CacheMgr::force_clean_cache ;
 718 sub force_clean_cache {
 719     my($self,$dir) = @_;
 720     return unless -e $dir;
 721     $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
 722         if $CPAN::DEBUG;
 723     File::Path::rmtree($dir);
 724     $self->{DU} -= $self->{SIZE}{$dir};
 725     delete $self->{SIZE}{$dir};
 726 }
 727
 728 #-> sub CPAN::CacheMgr::new ;
 729 sub new {
 730     my $class = shift;
 731     my $time = time;
 732     my($debug,$t2);
 733     $debug = "";
 734     my $self = {
 735                 ID => $CPAN::Config->{'build_dir'},
 736                 MAX => $CPAN::Config->{'build_cache'},
 737                 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
 738                 DU => 0
 739                };
 740     File::Path::mkpath($self->{ID});
 741     my $dh = DirHandle->new($self->{ID});
 742     bless $self, $class;
 743     $self->scan_cache;
 744     $t2 = time;
 745     $debug .= "timing of CacheMgr->new: ".($t2 - $time);
 746     $time = $t2;
 747     CPAN->debug($debug) if $CPAN::DEBUG;
 748     $self;
 749 }
 750
 751 #-> sub CPAN::CacheMgr::scan_cache ;
 752 sub scan_cache {
 753     my $self = shift;
 754     return if $self->{SCAN} eq 'never';
 755     $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
 756         unless $self->{SCAN} eq 'atstart';
 757     $CPAN::Frontend->myprint(
 758                              sprintf("Scanning cache %s for sizes\n",
 759                                      $self->{ID}));
 760     my $e;
 761     for $e ($self->entries($self->{ID})) {
 762         next if $e eq ".." || $e eq ".";
 763         $self->disk_usage($e);
 764         return if $CPAN::Signal;
 765     }
 766     $self->tidyup;
 767 }
 768
 769 package CPAN::Debug;
 770
 771 #-> sub CPAN::Debug::debug ;
 772 sub debug {
 773     my($self,$arg) = @_;
 774     my($caller,$func,$line,@rest) = caller(1); # caller(0) eg
 775                                                # Complete, caller(1)
 776                                                # eg readline
 777     ($caller) = caller(0);
 778     $caller =~ s/.*:://;
 779     $arg = "" unless defined $arg;
 780     my $rest = join "|", map { defined $_ ? $_ : "UNDEF" } @rest;
 781     if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){
 782         if ($arg and ref $arg) {
 783             eval { require Data::Dumper };
 784             if ($@) {
 785                 $CPAN::Frontend->myprint($arg->as_string);
 786             } else {
 787                 $CPAN::Frontend->myprint(Data::Dumper::Dumper($arg));
 788             }
 789         } else {
 790             $CPAN::Frontend->myprint("Debug($caller:$func,$line,[$rest]): $arg\n");
 791         }
 792     }
 793 }
 794
 795 package CPAN::Config;
 796
 797 #-> sub CPAN::Config::edit ;
 798 sub edit {
 799     my($class,@args) = @_;
 800     return unless @args;
 801     CPAN->debug("class[$class]args[".join(" | ",@args)."]");
 802     my($o,$str,$func,$args,$key_exists);
 803     $o = shift @args;
 804     if($can{$o}) {
 805         $class->$o(@args);
 806         return 1;
 807     } else {
 808         if (ref($CPAN::Config->{$o}) eq ARRAY) {
 809             $func = shift @args;
 810             $func ||= "";
 811             # Let's avoid eval, it's easier to comprehend without.
 812             if ($func eq "push") {
 813                 push @{$CPAN::Config->{$o}}, @args;
 814             } elsif ($func eq "pop") {
 815                 pop @{$CPAN::Config->{$o}};
 816             } elsif ($func eq "shift") {
 817                 shift @{$CPAN::Config->{$o}};
 818             } elsif ($func eq "unshift") {
 819                 unshift @{$CPAN::Config->{$o}}, @args;
 820             } elsif ($func eq "splice") {
 821                 splice @{$CPAN::Config->{$o}}, @args;
 822             } elsif (@args) {
 823                 $CPAN::Config->{$o} = [@args];
 824             } else {
 825                 $CPAN::Frontend->myprint(
 826                                          join "",
 827                                          "  $o  ",
 828                                          ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$o}),
 829                                          "\n"
 830                      );
 831             }
 832         } else {
 833             $CPAN::Config->{$o} = $args[0] if defined $args[0];
 834             $CPAN::Frontend->myprint("    $o    " .
 835                                      (defined $CPAN::Config->{$o} ?
 836                                       $CPAN::Config->{$o} : "UNDEFINED"));
 837         }
 838     }
 839 }
 840
 841 #-> sub CPAN::Config::commit ;
 842 sub commit {
 843     my($self,$configpm) = @_;
 844     unless (defined $configpm){
 845         $configpm ||= $INC{"CPAN/MyConfig.pm"};
 846         $configpm ||= $INC{"CPAN/Config.pm"};
 847         $configpm || Carp::confess(q{
 848 CPAN::Config::commit called without an argument.
 849 Please specify a filename where to save the configuration or try
 850 "o conf init" to have an interactive course through configing.
 851 });
 852     }
 853     my($mode);
 854     if (-f $configpm) {
 855         $mode = (stat $configpm)[2];
 856         if ($mode && ! -w _) {
 857             Carp::confess("$configpm is not writable");
 858         }
 859     }
 860
 861     my $msg = <<EOF unless $configpm =~ /MyConfig/;
 862
 863 # This is CPAN.pm's systemwide configuration file. This file provides
 864 # defaults for users, and the values can be changed in a per-user
 865 # configuration file. The user-config file is being looked for as
 866 # ~/.cpan/CPAN/MyConfig.pm.
 867
 868 EOF
 869     $msg ||= "\n";
 870     my($fh) = FileHandle->new;
 871     rename $configpm, "$configpm~" if -f $configpm;
 872     open $fh, ">$configpm" or warn "Couldn't open >$configpm: $!";
 873     $fh->print(qq[$msg\$CPAN::Config = \{\n]);
 874     foreach (sort keys %$CPAN::Config) {
 875         $fh->print(
 876                    "  '$_' => ",
 877                    ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}),
 878                    ",\n"
 879                   );
 880     }
 881
 882     $fh->print("};\n1;\n__END__\n");
 883     close $fh;
 884
 885     #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
 886     #chmod $mode, $configpm;
 887 ###why was that so?    $self->defaults;
 888     $CPAN::Frontend->myprint("commit: wrote $configpm\n");
 889     1;
 890 }
 891
 892 *default = \&defaults;
 893 #-> sub CPAN::Config::defaults ;
 894 sub defaults {
 895     my($self) = @_;
 896     $self->unload;
 897     $self->load;
 898     1;
 899 }
 900
 901 sub init {
 902     my($self) = @_;
 903     undef $CPAN::Config->{'inhibit_startup_message'}; # lazy trick to
 904                                                       # have the least
 905                                                       # important
 906                                                       # variable
 907                                                       # undefined
 908     $self->load;
 909     1;
 910 }
 911
 912 #-> sub CPAN::Config::load ;
 913 sub load {
 914     my($self) = shift;
 915     my(@miss);
 916     use Carp;
 917     eval {require CPAN::Config;};       # We eval because of some
 918                                         # MakeMaker problems
 919     unless ($dot_cpan++){
 920       unshift @INC, MM->catdir($ENV{HOME},".cpan");
 921       eval {require CPAN::MyConfig;};   # where you can override
 922                                         # system wide settings
 923       shift @INC;
 924     }
 925     return unless @miss = $self->not_loaded;
 926     # XXX better check for arrayrefs too
 927     require CPAN::FirstTime;
 928     my($configpm,$fh,$redo,$theycalled);
 929     $redo ||= "";
 930     $theycalled++ if @miss==1 && $miss[0] eq 'inhibit_startup_message';
 931     if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
 932         $configpm = $INC{"CPAN/Config.pm"};
 933         $redo++;
 934     } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
 935         $configpm = $INC{"CPAN/MyConfig.pm"};
 936         $redo++;
 937     } else {
 938         my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
 939         my($configpmdir) = MM->catdir($path_to_cpan,"CPAN");
 940         my($configpmtest) = MM->catfile($configpmdir,"Config.pm");
 941         if (-d $configpmdir or File::Path::mkpath($configpmdir)) {
 942             if (-w $configpmtest) {
 943                 $configpm = $configpmtest;
 944             } elsif (-w $configpmdir) {
 945                 #_#_# following code dumped core on me with 5.003_11, a.k.
 946                 unlink "$configpmtest.bak" if -f "$configpmtest.bak";
 947                 rename $configpmtest, "$configpmtest.bak" if -f $configpmtest;
 948                 my $fh = FileHandle->new;
 949                 if ($fh->open(">$configpmtest")) {
 950                     $fh->print("1;\n");
 951                     $configpm = $configpmtest;
 952                 } else {
 953                     # Should never happen
 954                     Carp::confess("Cannot open >$configpmtest");
 955                 }
 956             }
 957         }
 958         unless ($configpm) {
 959             $configpmdir = MM->catdir($ENV{HOME},".cpan","CPAN");
 960             File::Path::mkpath($configpmdir);
 961             $configpmtest = MM->catfile($configpmdir,"MyConfig.pm");
 962             if (-w $configpmtest) {
 963                 $configpm = $configpmtest;
 964             } elsif (-w $configpmdir) {
 965                 #_#_# following code dumped core on me with 5.003_11, a.k.
 966                 my $fh = FileHandle->new;
 967                 if ($fh->open(">$configpmtest")) {
 968                     $fh->print("1;\n");
 969                     $configpm = $configpmtest;
 970                 } else {
 971                     # Should never happen
 972                     Carp::confess("Cannot open >$configpmtest");
 973                 }
 974             } else {
 975                 Carp::confess(qq{WARNING: CPAN.pm is unable to }.
 976                               qq{create a configuration file.});
 977             }
 978         }
 979     }
 980     local($") = ", ";
 981     $CPAN::Frontend->myprint(<<END) if $redo && ! $theycalled;
 982 We have to reconfigure CPAN.pm due to following uninitialized parameters:
 983
 984 @miss
 985 END
 986     $CPAN::Frontend->myprint(qq{
 987 $configpm initialized.
 988 });
 989     sleep 2;
 990     CPAN::FirstTime::init($configpm);
 991 }
 992
 993 #-> sub CPAN::Config::not_loaded ;
 994 sub not_loaded {
 995     my(@miss);
 996     for (qw(
 997             cpan_home keep_source_where build_dir build_cache scan_cache
 998             index_expire gzip tar unzip make pager makepl_arg make_arg
 999             make_install_arg urllist inhibit_startup_message
1000             ftp_proxy http_proxy no_proxy prerequisites_policy
1001            )) {
1002         push @miss, $_ unless defined $CPAN::Config->{$_};
1003     }
1004     return @miss;
1005 }
1006
1007 #-> sub CPAN::Config::unload ;
1008 sub unload {
1009     delete $INC{'CPAN/MyConfig.pm'};
1010     delete $INC{'CPAN/Config.pm'};
1011 }
1012
1013 #-> sub CPAN::Config::help ;
1014 sub help {
1015     $CPAN::Frontend->myprint(q[
1016 Known options:
1017   defaults  reload default config values from disk
1018   commit    commit session changes to disk
1019   init      go through a dialog to set all parameters
1020
1021 You may edit key values in the follow fashion:
1022
1023   o conf build_cache 15
1024
1025   o conf build_dir "/foo/bar"
1026
1027   o conf urllist shift
1028
1029   o conf urllist unshift ftp://ftp.foo.bar/
1030
1031 ]);
1032     undef; #don't reprint CPAN::Config
1033 }
1034
1035 #-> sub CPAN::Config::cpl ;
1036 sub cpl {
1037     my($word,$line,$pos) = @_;
1038     $word ||= "";
1039     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
1040     my(@words) = split " ", substr($line,0,$pos+1);
1041     if (
1042         defined($words[2])
1043         and
1044         (
1045          $words[2] =~ /list$/ && @words == 3
1046          ||
1047          $words[2] =~ /list$/ && @words == 4 && length($word)
1048         )
1049        ) {
1050         return grep /^\Q$word\E/, qw(splice shift unshift pop push);
1051     } elsif (@words >= 4) {
1052         return ();
1053     }
1054     my(@o_conf) = (keys %CPAN::Config::can, keys %$CPAN::Config);
1055     return grep /^\Q$word\E/, @o_conf;
1056 }
1057
1058 package CPAN::Shell;
1059
1060 #-> sub CPAN::Shell::h ;
1061 sub h {
1062     my($class,$about) = @_;
1063     if (defined $about) {
1064         $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1065     } else {
1066         $CPAN::Frontend->myprint(q{
1067 command   arguments       description
1068 a         string                  authors
1069 b         or              display bundles
1070 d         /regex/         info    distributions
1071 m         or              about   modules
1072 i         none                    anything of above
1073
1074 r          as             reinstall recommendations
1075 u          above          uninstalled distributions
1076 See manpage for autobundle, recompile, force, look, etc.
1077
1078 make                      make
1079 test      modules,        make test (implies make)
1080 install   dists, bundles, make install (implies test)
1081 clean     "r" or "u"      make clean
1082 readme                    display the README file
1083
1084 reload    index|cpan    load most recent indices/CPAN.pm
1085 h or ?                  display this menu
1086 o         various       set and query options
1087 !         perl-code     eval a perl command
1088 q                       quit the shell subroutine
1089 });
1090     }
1091 }
1092
1093 *help = \&h;
1094
1095 #-> sub CPAN::Shell::a ;
1096 sub a { $CPAN::Frontend->myprint(shift->format_result('Author',@_));}
1097 #-> sub CPAN::Shell::b ;
1098 sub b {
1099     my($self,@which) = @_;
1100     CPAN->debug("which[@which]") if $CPAN::DEBUG;
1101     my($incdir,$bdir,$dh);
1102     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1103         $bdir = MM->catdir($incdir,"Bundle");
1104         if ($dh = DirHandle->new($bdir)) { # may fail
1105             my($entry);
1106             for $entry ($dh->read) {
1107                 next if -d MM->catdir($bdir,$entry);
1108                 next unless $entry =~ s/\.pm$//;
1109                 $CPAN::META->instance('CPAN::Bundle',"Bundle::$entry");
1110             }
1111         }
1112     }
1113     $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1114 }
1115 #-> sub CPAN::Shell::d ;
1116 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1117 #-> sub CPAN::Shell::m ;
1118 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1119     $CPAN::Frontend->myprint(shift->format_result('Module',@_));
1120 }
1121
1122 #-> sub CPAN::Shell::i ;
1123 sub i {
1124     my($self) = shift;
1125     my(@args) = @_;
1126     my(@type,$type,@m);
1127     @type = qw/Author Bundle Distribution Module/;
1128     @args = '/./' unless @args;
1129     my(@result);
1130     for $type (@type) {
1131         push @result, $self->expand($type,@args);
1132     }
1133     my $result =  @result == 1 ?
1134         $result[0]->as_string :
1135             join "", map {$_->as_glimpse} @result;
1136     $result ||= "No objects found of any type for argument @args\n";
1137     $CPAN::Frontend->myprint($result);
1138 }
1139
1140 #-> sub CPAN::Shell::o ;
1141 sub o {
1142     my($self,$o_type,@o_what) = @_;
1143     $o_type ||= "";
1144     CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1145     if ($o_type eq 'conf') {
1146         shift @o_what if @o_what && $o_what[0] eq 'help';
1147         if (!@o_what) {
1148             my($k,$v);
1149             $CPAN::Frontend->myprint("CPAN::Config options");
1150             if (exists $INC{'CPAN/Config.pm'}) {
1151               $CPAN::Frontend->myprint(" from $INC{'CPAN/Config.pm'}");
1152             }
1153             if (exists $INC{'CPAN/MyConfig.pm'}) {
1154               $CPAN::Frontend->myprint(" and $INC{'CPAN/MyConfig.pm'}");
1155             }
1156             $CPAN::Frontend->myprint(":\n");
1157             for $k (sort keys %CPAN::Config::can) {
1158                 $v = $CPAN::Config::can{$k};
1159                 $CPAN::Frontend->myprint(sprintf "    %-18s %s\n", $k, $v);
1160             }
1161             $CPAN::Frontend->myprint("\n");
1162             for $k (sort keys %$CPAN::Config) {
1163                 $v = $CPAN::Config->{$k};
1164                 if (ref $v) {
1165                     $CPAN::Frontend->myprint(
1166                                              join(
1167                                                   "",
1168                                                   sprintf(
1169                                                           "    %-18s\n",
1170                                                           $k
1171                                                          ),
1172                                                   map {"\t$_\n"} @{$v}
1173                                                  )
1174                                             );
1175                 } else {
1176                     $CPAN::Frontend->myprint(sprintf "    %-18s %s\n", $k, $v);
1177                 }
1178             }
1179             $CPAN::Frontend->myprint("\n");
1180         } elsif (!CPAN::Config->edit(@o_what)) {
1181             $CPAN::Frontend->myprint(qq[Type 'o conf' to view configuration edit options\n\n]);
1182         }
1183     } elsif ($o_type eq 'debug') {
1184         my(%valid);
1185         @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1186         if (@o_what) {
1187             while (@o_what) {
1188                 my($what) = shift @o_what;
1189                 if ( exists $CPAN::DEBUG{$what} ) {
1190                     $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1191                 } elsif ($what =~ /^\d/) {
1192                     $CPAN::DEBUG = $what;
1193                 } elsif (lc $what eq 'all') {
1194                     my($max) = 0;
1195                     for (values %CPAN::DEBUG) {
1196                         $max += $_;
1197                     }
1198                     $CPAN::DEBUG = $max;
1199                 } else {
1200                     my($known) = 0;
1201                     for (keys %CPAN::DEBUG) {
1202                         next unless lc($_) eq lc($what);
1203                         $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1204                         $known = 1;
1205                     }
1206                     $CPAN::Frontend->myprint("unknown argument [$what]\n")
1207                         unless $known;
1208                 }
1209             }
1210         } else {
1211             $CPAN::Frontend->myprint("Valid options for debug are ".
1212                                      join(", ",sort(keys %CPAN::DEBUG), 'all').
1213                     qq{ or a number. Completion works on the options. }.
1214                         qq{Case is ignored.\n\n});
1215         }
1216         if ($CPAN::DEBUG) {
1217             $CPAN::Frontend->myprint("Options set for debugging:\n");
1218             my($k,$v);
1219             for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1220                 $v = $CPAN::DEBUG{$k};
1221                 $CPAN::Frontend->myprint(sprintf "    %-14s(%s)\n", $k, $v) if $v & $CPAN::DEBUG;
1222             }
1223         } else {
1224             $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1225         }
1226     } else {
1227         $CPAN::Frontend->myprint(qq{
1228 Known options:
1229   conf    set or get configuration variables
1230   debug   set or get debugging options
1231 });
1232     }
1233 }
1234
1235 #-> sub CPAN::Shell::reload ;
1236 sub reload {
1237     my($self,$command,@arg) = @_;
1238     $command ||= "";
1239     $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1240     if ($command =~ /cpan/i) {
1241         CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG;
1242         my $fh = FileHandle->new($INC{'CPAN.pm'});
1243         local($/);
1244         $redef = 0;
1245         local($SIG{__WARN__})
1246             = sub {
1247                 if ( $_[0] =~ /Subroutine (\w+) redefined/ ) {
1248                   my($subr) = $1;
1249                   ++$redef;
1250                   local($|) = 1;
1251                   # $CPAN::Frontend->myprint(".($subr)");
1252                   $CPAN::Frontend->myprint(".");
1253                   return;
1254                 }
1255                 warn @_;
1256             };
1257         eval <$fh>;
1258         warn $@ if $@;
1259         $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1260     } elsif ($command =~ /index/) {
1261       CPAN::Index->force_reload;
1262     } else {
1263       $CPAN::Frontend->myprint(qq{cpan     re-evals the CPAN.pm file
1264 index    re-reads the index files
1265 });
1266     }
1267 }
1268
1269 #-> sub CPAN::Shell::_binary_extensions ;
1270 sub _binary_extensions {
1271     my($self) = shift @_;
1272     my(@result,$module,%seen,%need,$headerdone);
1273     my $isaperl = q{perl5[._-]\\d{3}(_[0-4][0-9])?\\.tar[._-]gz$};
1274     for $module ($self->expand('Module','/./')) {
1275         my $file  = $module->cpan_file;
1276         next if $file eq "N/A";
1277         next if $file =~ /^Contact Author/;
1278         next if $file =~ / $isaperl /xo;
1279         next unless $module->xs_file;
1280         local($|) = 1;
1281         $CPAN::Frontend->myprint(".");
1282         push @result, $module;
1283     }
1284 #    print join " | ", @result;
1285     $CPAN::Frontend->myprint("\n");
1286     return @result;
1287 }
1288
1289 #-> sub CPAN::Shell::recompile ;
1290 sub recompile {
1291     my($self) = shift @_;
1292     my($module,@module,$cpan_file,%dist);
1293     @module = $self->_binary_extensions();
1294     for $module (@module){  # we force now and compile later, so we
1295                             # don't do it twice
1296         $cpan_file = $module->cpan_file;
1297         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1298         $pack->force;
1299         $dist{$cpan_file}++;
1300     }
1301     for $cpan_file (sort keys %dist) {
1302         $CPAN::Frontend->myprint("  CPAN: Recompiling $cpan_file\n\n");
1303         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1304         $pack->install;
1305         $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1306                            # stop a package from recompiling,
1307                            # e.g. IO-1.12 when we have perl5.003_10
1308     }
1309 }
1310
1311 #-> sub CPAN::Shell::_u_r_common ;
1312 sub _u_r_common {
1313     my($self) = shift @_;
1314     my($what) = shift @_;
1315     CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
1316     Carp::croak "Usage: \$obj->_u_r_common($what)" unless defined $what;
1317     Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless $what =~ /^[aru]$/;
1318     my(@args) = @_;
1319     @args = '/./' unless @args;
1320     my(@result,$module,%seen,%need,$headerdone,
1321        $version_undefs,$version_zeroes);
1322     $version_undefs = $version_zeroes = 0;
1323     my $sprintf = "%-25s %9s %9s  %s\n";
1324     for $module ($self->expand('Module',@args)) {
1325         my $file  = $module->cpan_file;
1326         next unless defined $file; # ??
1327         my($latest) = $module->cpan_version;
1328         my($inst_file) = $module->inst_file;
1329         my($have);
1330         return if $CPAN::Signal;
1331         if ($inst_file){
1332             if ($what eq "a") {
1333                 $have = $module->inst_version;
1334             } elsif ($what eq "r") {
1335                 $have = $module->inst_version;
1336                 local($^W) = 0;
1337                 if ($have eq "undef"){
1338                     $version_undefs++;
1339                 } elsif ($have == 0){
1340                     $version_zeroes++;
1341                 }
1342                 next if $have >= $latest;
1343 # to be pedantic we should probably say:
1344 #    && !($have eq "undef" && $latest ne "undef" && $latest gt "");
1345 # to catch the case where CPAN has a version 0 and we have a version undef
1346             } elsif ($what eq "u") {
1347                 next;
1348             }
1349         } else {
1350             if ($what eq "a") {
1351                 next;
1352             } elsif ($what eq "r") {
1353                 next;
1354             } elsif ($what eq "u") {
1355                 $have = "-";
1356             }
1357         }
1358         return if $CPAN::Signal; # this is sometimes lengthy
1359         $seen{$file} ||= 0;
1360         if ($what eq "a") {
1361             push @result, sprintf "%s %s\n", $module->id, $have;
1362         } elsif ($what eq "r") {
1363             push @result, $module->id;
1364             next if $seen{$file}++;
1365         } elsif ($what eq "u") {
1366             push @result, $module->id;
1367             next if $seen{$file}++;
1368             next if $file =~ /^Contact/;
1369         }
1370         unless ($headerdone++){
1371             $CPAN::Frontend->myprint("\n");
1372             $CPAN::Frontend->myprint(sprintf(
1373                    $sprintf,
1374                    "Package namespace",
1375                    "installed",
1376                    "latest",
1377                    "in CPAN file"
1378                    ));
1379         }
1380         $latest = substr($latest,0,8) if length($latest) > 8;
1381         $have = substr($have,0,8) if length($have) > 8;
1382         $CPAN::Frontend->myprint(sprintf $sprintf, $module->id, $have, $latest, $file);
1383         $need{$module->id}++;
1384     }
1385     unless (%need) {
1386         if ($what eq "u") {
1387             $CPAN::Frontend->myprint("No modules found for @args\n");
1388         } elsif ($what eq "r") {
1389             $CPAN::Frontend->myprint("All modules are up to date for @args\n");
1390         }
1391     }
1392     if ($what eq "r") {
1393         if ($version_zeroes) {
1394             my $s_has = $version_zeroes > 1 ? "s have" : " has";
1395             $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
1396                 qq{a version number of 0\n});
1397         }
1398         if ($version_undefs) {
1399             my $s_has = $version_undefs > 1 ? "s have" : " has";
1400             $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
1401                 qq{parseable version number\n});
1402         }
1403     }
1404     @result;
1405 }
1406
1407 #-> sub CPAN::Shell::r ;
1408 sub r {
1409     shift->_u_r_common("r",@_);
1410 }
1411
1412 #-> sub CPAN::Shell::u ;
1413 sub u {
1414     shift->_u_r_common("u",@_);
1415 }
1416
1417 #-> sub CPAN::Shell::autobundle ;
1418 sub autobundle {
1419     my($self) = shift;
1420     my(@bundle) = $self->_u_r_common("a",@_);
1421     my($todir) = MM->catdir($CPAN::Config->{'cpan_home'},"Bundle");
1422     File::Path::mkpath($todir);
1423     unless (-d $todir) {
1424         $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
1425         return;
1426     }
1427     my($y,$m,$d) =  (localtime)[5,4,3];
1428     $y+=1900;
1429     $m++;
1430     my($c) = 0;
1431     my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
1432     my($to) = MM->catfile($todir,"$me.pm");
1433     while (-f $to) {
1434         $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
1435         $to = MM->catfile($todir,"$me.pm");
1436     }
1437     my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
1438     $fh->print(
1439                "package Bundle::$me;\n\n",
1440                "\$VERSION = '0.01';\n\n",
1441                "1;\n\n",
1442                "__END__\n\n",
1443                "=head1 NAME\n\n",
1444                "Bundle::$me - Snapshot of installation on ",
1445                $Config::Config{'myhostname'},
1446                " on ",
1447                scalar(localtime),
1448                "\n\n=head1 SYNOPSIS\n\n",
1449                "perl -MCPAN -e 'install Bundle::$me'\n\n",
1450                "=head1 CONTENTS\n\n",
1451                join("\n", @bundle),
1452                "\n\n=head1 CONFIGURATION\n\n",
1453                Config->myconfig,
1454                "\n\n=head1 AUTHOR\n\n",
1455                "This Bundle has been generated automatically ",
1456                "by the autobundle routine in CPAN.pm.\n",
1457               );
1458     $fh->close;
1459     $CPAN::Frontend->myprint("\nWrote bundle file
1460     $to\n\n");
1461 }
1462
1463 #-> sub CPAN::Shell::expand ;
1464 sub expand {
1465     shift;
1466     my($type,@args) = @_;
1467     my($arg,@m);
1468     for $arg (@args) {
1469         my $regex;
1470         if ($arg =~ m|^/(.*)/$|) {
1471             $regex = $1;
1472         }
1473         my $class = "CPAN::$type";
1474         my $obj;
1475         if (defined $regex) {
1476             for $obj ( sort {$a->id cmp $b->id} $CPAN::META->all($class)) {
1477                 push @m, $obj
1478                     if
1479                         $obj->id =~ /$regex/i
1480                             or
1481                         (
1482                          (
1483                           $] < 5.00303 ### provide sort of compatibility with 5.003
1484                           ||
1485                           $obj->can('name')
1486                          )
1487                          &&
1488                          $obj->name  =~ /$regex/i
1489                         );
1490             }
1491         } else {
1492             my($xarg) = $arg;
1493             if ( $type eq 'Bundle' ) {
1494                 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
1495             }
1496             if ($CPAN::META->exists($class,$xarg)) {
1497                 $obj = $CPAN::META->instance($class,$xarg);
1498             } elsif ($CPAN::META->exists($class,$arg)) {
1499                 $obj = $CPAN::META->instance($class,$arg);
1500             } else {
1501                 next;
1502             }
1503             push @m, $obj;
1504         }
1505     }
1506     return wantarray ? @m : $m[0];
1507 }
1508
1509 #-> sub CPAN::Shell::format_result ;
1510 sub format_result {
1511     my($self) = shift;
1512     my($type,@args) = @_;
1513     @args = '/./' unless @args;
1514     my(@result) = $self->expand($type,@args);
1515     my $result =  @result == 1 ?
1516         $result[0]->as_string :
1517             join "", map {$_->as_glimpse} @result;
1518     $result ||= "No objects of type $type found for argument @args\n";
1519     $result;
1520 }
1521
1522 # The only reason for this method is currently to have a reliable
1523 # debugging utility that reveals which output is going through which
1524 # channel. No, I don't like the colors ;-)
1525 sub print_ornamented {
1526     my($self,$what,$ornament) = @_;
1527     my $longest = 0;
1528     my $ornamenting = 0; # turn the colors on
1529
1530     if ($ornamenting) {
1531         unless (defined &color) {
1532             if ($CPAN::META->has_inst("Term::ANSIColor")) {
1533                 import Term::ANSIColor "color";
1534             } else {
1535                 *color = sub { return "" };
1536             }
1537         }
1538         my $line;
1539         for $line (split /\n/, $what) {
1540             $longest = length($line) if length($line) > $longest;
1541         }
1542         my $sprintf = "%-" . $longest . "s";
1543         while ($what){
1544             $what =~ s/(.*\n?)//m;
1545             my $line = $1;
1546             last unless $line;
1547             my($nl) = chomp $line ? "\n" : "";
1548             #   print "line[$line]ornament[$ornament]sprintf[$sprintf]\n";
1549             print color($ornament), sprintf($sprintf,$line), color("reset"), $nl;
1550         }
1551     } else {
1552         print $what;
1553     }
1554 }
1555
1556 sub myprint {
1557     my($self,$what) = @_;
1558     $self->print_ornamented($what, 'bold blue on_yellow');
1559 }
1560
1561 sub myexit {
1562     my($self,$what) = @_;
1563     $self->myprint($what);
1564     exit;
1565 }
1566
1567 sub mywarn {
1568     my($self,$what) = @_;
1569     $self->print_ornamented($what, 'bold red on_yellow');
1570 }
1571
1572 sub myconfess {
1573     my($self,$what) = @_;
1574     $self->print_ornamented($what, 'bold red on_white');
1575     Carp::confess "died";
1576 }
1577
1578 sub mydie {
1579     my($self,$what) = @_;
1580     $self->print_ornamented($what, 'bold red on_white');
1581     die "\n";
1582 }
1583
1584 #-> sub CPAN::Shell::rematein ;
1585 # RE-adme||MA-ke||TE-st||IN-stall
1586 sub rematein {
1587     shift;
1588     my($meth,@some) = @_;
1589     my $pragma = "";
1590     if ($meth eq 'force') {
1591         $pragma = $meth;
1592         $meth = shift @some;
1593     }
1594     CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG;
1595     my($s,@s);
1596     foreach $s (@some) {
1597       CPAN::Queue->new($s);
1598     }
1599     while ($s = CPAN::Queue->first) {
1600         my $obj;
1601         if (ref $s) {
1602             $obj = $s;
1603         } elsif ($s =~ m|/|) { # looks like a file
1604             $obj = $CPAN::META->instance('CPAN::Distribution',$s);
1605         } elsif ($s =~ m|^Bundle::|) {
1606             $obj = $CPAN::META->instance('CPAN::Bundle',$s);
1607         } else {
1608             $obj = $CPAN::META->instance('CPAN::Module',$s)
1609                 if $CPAN::META->exists('CPAN::Module',$s);
1610         }
1611         if (ref $obj) {
1612             CPAN->debug(
1613                         qq{pragma[$pragma]meth[$meth]obj[$obj]as_string\[}.
1614                         $obj->as_string.
1615                         qq{\]}
1616                        ) if $CPAN::DEBUG;
1617             $obj->$pragma()
1618                 if
1619                     $pragma
1620                         &&
1621                     ($] < 5.00303 || $obj->can($pragma)); ###
1622                                                           ### compatibility
1623                                                           ### with
1624                                                           ### 5.003
1625             if ($]>=5.00303 && $obj->can('called_for')) {
1626               $obj->called_for($s);
1627             }
1628             CPAN::Queue->delete($s) if $obj->$meth(); # if it is more
1629                                                       # than once in
1630                                                       # the queue
1631         } elsif ($CPAN::META->exists('CPAN::Author',$s)) {
1632             $obj = $CPAN::META->instance('CPAN::Author',$s);
1633             $CPAN::Frontend->myprint(
1634                                      join "",
1635                                      "Don't be silly, you can't $meth ",
1636                                      $obj->fullname,
1637                                      " ;-)\n"
1638                                     );
1639         } else {
1640             $CPAN::Frontend
1641                 ->myprint(qq{Warning: Cannot $meth $s, }.
1642                           qq{don\'t know what it is.
1643 Try the command
1644
1645     i /$s/
1646
1647 to find objects with similar identifiers.
1648 });
1649         }
1650         CPAN::Queue->delete_first($s);
1651     }
1652 }
1653
1654 #-> sub CPAN::Shell::force ;
1655 sub force   { shift->rematein('force',@_); }
1656 #-> sub CPAN::Shell::get ;
1657 sub get     { shift->rematein('get',@_); }
1658 #-> sub CPAN::Shell::readme ;
1659 sub readme  { shift->rematein('readme',@_); }
1660 #-> sub CPAN::Shell::make ;
1661 sub make    { shift->rematein('make',@_); }
1662 #-> sub CPAN::Shell::test ;
1663 sub test    { shift->rematein('test',@_); }
1664 #-> sub CPAN::Shell::install ;
1665 sub install { shift->rematein('install',@_); }
1666 #-> sub CPAN::Shell::clean ;
1667 sub clean   { shift->rematein('clean',@_); }
1668 #-> sub CPAN::Shell::look ;
1669 sub look   { shift->rematein('look',@_); }
1670
1671 package CPAN::FTP;
1672
1673 #-> sub CPAN::FTP::ftp_get ;
1674 sub ftp_get {
1675   my($class,$host,$dir,$file,$target) = @_;
1676   $class->debug(
1677                 qq[Going to fetch file [$file] from dir [$dir]
1678         on host [$host] as local [$target]\n]
1679                       ) if $CPAN::DEBUG;
1680   my $ftp = Net::FTP->new($host);
1681   return 0 unless defined $ftp;
1682   $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
1683   $class->debug(qq[Going to ->login("anonymous","$Config::Config{'cf_email'}")\n]);
1684   unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
1685     warn "Couldn't login on $host";
1686     return;
1687   }
1688   unless ( $ftp->cwd($dir) ){
1689     warn "Couldn't cwd $dir";
1690     return;
1691   }
1692   $ftp->binary;
1693   $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
1694   unless ( $ftp->get($file,$target) ){
1695     warn "Couldn't fetch $file from $host\n";
1696     return;
1697   }
1698   $ftp->quit; # it's ok if this fails
1699   return 1;
1700 }
1701
1702 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
1703
1704  # leach,> *** /install/perl/live/lib/CPAN.pm-  Wed Sep 24 13:08:48 1997
1705  # leach,> --- /tmp/cp  Wed Sep 24 13:26:40 1997
1706  # leach,> ***************
1707  # leach,> *** 1562,1567 ****
1708  # leach,> --- 1562,1580 ----
1709  # leach,>       return 1 if substr($url,0,4) eq "file";
1710  # leach,>       return 1 unless $url =~ m|://([^/]+)|;
1711  # leach,>       my $host = $1;
1712  # leach,> +     my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
1713  # leach,> +     if ($proxy) {
1714  # leach,> +         $proxy =~ m|://([^/:]+)|;
1715  # leach,> +         $proxy = $1;
1716  # leach,> +         my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
1717  # leach,> +         if ($noproxy) {
1718  # leach,> +             if ($host !~ /$noproxy$/) {
1719  # leach,> +                 $host = $proxy;
1720  # leach,> +             }
1721  # leach,> +         } else {
1722  # leach,> +             $host = $proxy;
1723  # leach,> +         }
1724  # leach,> +     }
1725  # leach,>       require Net::Ping;
1726  # leach,>       return 1 unless $Net::Ping::VERSION >= 2;
1727  # leach,>       my $p;
1728
1729
1730 # this is quite optimistic and returns one on several occasions where
1731 # inappropriate. But this does no harm. It would do harm if we were
1732 # too pessimistic (as I was before the http_proxy
1733 sub is_reachable {
1734     my($self,$url) = @_;
1735     return 1; # we can't simply roll our own, firewalls may break ping
1736     return 0 unless $url;
1737     return 1 if substr($url,0,4) eq "file";
1738     return 1 unless $url =~ m|^(\w+)://([^/]+)|;
1739     my $proxytype = $1 . "_proxy"; # ftp_proxy or http_proxy
1740     my $host = $2;
1741     return 1 if $CPAN::Config->{$proxytype} || $ENV{$proxytype};
1742     require Net::Ping;
1743     return 1 unless $Net::Ping::VERSION >= 2;
1744     my $p;
1745     # 1.3101 had it different: only if the first eval raised an
1746     # exception we tried it with TCP. Now we are happy if icmp wins
1747     # the order and return, we don't even check for $@. Thanks to
1748     # thayer@uis.edu for the suggestion.
1749     eval {$p = Net::Ping->new("icmp");};
1750     return 1 if $p && ref($p) && $p->ping($host, 10);
1751     eval {$p = Net::Ping->new("tcp");};
1752     $CPAN::Frontend->mydie($@) if $@;
1753     return $p->ping($host, 10);
1754 }
1755
1756 #-> sub CPAN::FTP::localize ;
1757 # sorry for the ugly code here, I'll clean it up as soon as Net::FTP
1758 # is in the core
1759 sub localize {
1760     my($self,$file,$aslocal,$force) = @_;
1761     $force ||= 0;
1762     Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
1763         unless defined $aslocal;
1764     $self->debug("file[$file] aslocal[$aslocal] force[$force]")
1765         if $CPAN::DEBUG;
1766
1767     return $aslocal if -f $aslocal && -r _ && !($force & 1);
1768     my($restore) = 0;
1769     if (-f $aslocal){
1770         rename $aslocal, "$aslocal.bak";
1771         $restore++;
1772     }
1773
1774     my($aslocal_dir) = File::Basename::dirname($aslocal);
1775     File::Path::mkpath($aslocal_dir);
1776     $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
1777         qq{directory "$aslocal_dir".
1778     I\'ll continue, but if you encounter problems, they may be due
1779     to insufficient permissions.\n}) unless -w $aslocal_dir;
1780
1781     # Inheritance is not easier to manage than a few if/else branches
1782     if ($CPAN::META->has_inst('LWP')) {
1783         require LWP::UserAgent;
1784         unless ($Ua) {
1785             $Ua = LWP::UserAgent->new;
1786             my($var);
1787             $Ua->proxy('ftp',  $var)
1788                 if $var = $CPAN::Config->{'ftp_proxy'} || $ENV{'ftp_proxy'};
1789             $Ua->proxy('http', $var)
1790                 if $var = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
1791             $Ua->no_proxy($var)
1792                 if $var = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
1793         }
1794     }
1795
1796     # Try the list of urls for each single object. We keep a record
1797     # where we did get a file from
1798     my(@reordered,$last);
1799     $CPAN::Config->{urllist} ||= [];
1800     $last = $#{$CPAN::Config->{urllist}};
1801     if ($force & 2) { # local cpans probably out of date, don't reorder
1802         @reordered = (0..$last);
1803     } else {
1804         @reordered =
1805             sort {
1806                 (substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
1807                     <=>
1808                 (substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
1809                     or
1810                 defined($Thesite)
1811                     and
1812                 ($b == $Thesite)
1813                     <=>
1814                 ($a == $Thesite)
1815             } 0..$last;
1816     }
1817     my($level,@levels);
1818     if ($Themethod) {
1819         @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
1820     } else {
1821         @levels = qw/easy hard hardest/;
1822     }
1823     for $level (@levels) {
1824         my $method = "host$level";
1825         my @host_seq = $level eq "easy" ?
1826             @reordered : 0..$last;  # reordered has CDROM up front
1827         @host_seq = (0) unless @host_seq;
1828         my $ret = $self->$method(\@host_seq,$file,$aslocal);
1829         if ($ret) {
1830           $Themethod = $level;
1831           $self->debug("level[$level]") if $CPAN::DEBUG;
1832           return $ret;
1833         } else {
1834           unlink $aslocal;
1835         }
1836     }
1837     my(@mess);
1838     push @mess,
1839     qq{Please check, if the URLs I found in your configuration file \(}.
1840         join(", ", @{$CPAN::Config->{urllist}}).
1841             qq{\) are valid. The urllist can be edited.},
1842             qq{E.g. with ``o conf urllist push ftp://myurl/''};
1843     $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
1844     sleep 2;
1845     $CPAN::Frontend->myprint("Cannot fetch $file\n\n");
1846     if ($restore) {
1847         rename "$aslocal.bak", $aslocal;
1848         $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
1849                                  $self->ls($aslocal));
1850         return $aslocal;
1851     }
1852     return;
1853 }
1854
1855 sub hosteasy {
1856     my($self,$host_seq,$file,$aslocal) = @_;
1857     my($i);
1858   HOSTEASY: for $i (@$host_seq) {
1859       my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
1860         unless ($self->is_reachable($url)) {
1861             $CPAN::Frontend->myprint("Skipping $url (seems to be not reachable)\n");
1862             sleep 2;
1863             next;
1864         }
1865         $url .= "/" unless substr($url,-1) eq "/";
1866         $url .= $file;
1867         $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
1868         if ($url =~ /^file:/) {
1869             my $l;
1870             if ($CPAN::META->has_inst('LWP')) {
1871                 require URI::URL;
1872                 my $u =  URI::URL->new($url);
1873                 $l = $u->path;
1874             } else { # works only on Unix, is poorly constructed, but
1875                 # hopefully better than nothing.
1876                 # RFC 1738 says fileurl BNF is
1877                 # fileurl = "file://" [ host | "localhost" ] "/" fpath
1878                 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
1879                 # the code
1880                 ($l = $url) =~ s,^file://[^/]+,,; # discard the host part
1881                 $l =~ s/^file://;       # assume they meant file://localhost
1882             }
1883             if ( -f $l && -r _) {
1884                 $Thesite = $i;
1885                 return $l;
1886             }
1887             # Maybe mirror has compressed it?
1888             if (-f "$l.gz") {
1889                 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
1890                 CPAN::Tarzip->gunzip("$l.gz", $aslocal);
1891                 if ( -f $aslocal) {
1892                     $Thesite = $i;
1893                     return $aslocal;
1894                 }
1895             }
1896         }
1897       if ($CPAN::META->has_inst('LWP')) {
1898           $CPAN::Frontend->myprint("Fetching with LWP:
1899   $url
1900 ");
1901           unless ($Ua) {
1902             require LWP::UserAgent;
1903             $Ua = LWP::UserAgent->new;
1904           }
1905           my $res = $Ua->mirror($url, $aslocal);
1906           if ($res->is_success) {
1907             $Thesite = $i;
1908             return $aslocal;
1909           } elsif ($url !~ /\.gz$/) {
1910             my $gzurl = "$url.gz";
1911             $CPAN::Frontend->myprint("Fetching with LWP:
1912   $gzurl
1913 ");
1914             $res = $Ua->mirror($gzurl, "$aslocal.gz");
1915             if ($res->is_success &&
1916                 CPAN::Tarzip->gunzip("$aslocal.gz",$aslocal)
1917                ) {
1918               $Thesite = $i;
1919               return $aslocal;
1920             } else {
1921               # next HOSTEASY ;
1922             }
1923           } else {
1924             # Alan Burlison informed me that in firewall envs Net::FTP
1925             # can still succeed where LWP fails. So we do not skip
1926             # Net::FTP anymore when LWP is available.
1927             # next HOSTEASY ;
1928           }
1929         } else {
1930           $self->debug("LWP not installed") if $CPAN::DEBUG;
1931         }
1932         if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
1933             # that's the nice and easy way thanks to Graham
1934             my($host,$dir,$getfile) = ($1,$2,$3);
1935             if ($CPAN::META->has_inst('Net::FTP')) {
1936                 $dir =~ s|/+|/|g;
1937                 $CPAN::Frontend->myprint("Fetching with Net::FTP:
1938   $url
1939 ");
1940                 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
1941                              "aslocal[$aslocal]") if $CPAN::DEBUG;
1942                 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
1943                     $Thesite = $i;
1944                     return $aslocal;
1945                 }
1946                 if ($aslocal !~ /\.gz$/) {
1947                     my $gz = "$aslocal.gz";
1948                     $CPAN::Frontend->myprint("Fetching with Net::FTP
1949   $url.gz
1950 ");
1951                    if (CPAN::FTP->ftp_get($host,
1952                                            $dir,
1953                                            "$getfile.gz",
1954                                            $gz) &&
1955                         CPAN::Tarzip->gunzip($gz,$aslocal)
1956                        ){
1957                         $Thesite = $i;
1958                         return $aslocal;
1959                     }
1960                 }
1961                 # next HOSTEASY;
1962             }
1963         }
1964     }
1965 }
1966
1967 sub hosthard {
1968   my($self,$host_seq,$file,$aslocal) = @_;
1969
1970   # Came back if Net::FTP couldn't establish connection (or
1971   # failed otherwise) Maybe they are behind a firewall, but they
1972   # gave us a socksified (or other) ftp program...
1973
1974   my($i);
1975   my($devnull) = $CPAN::Config->{devnull} || "";
1976   # < /dev/null ";
1977   my($aslocal_dir) = File::Basename::dirname($aslocal);
1978   File::Path::mkpath($aslocal_dir);
1979   HOSTHARD: for $i (@$host_seq) {
1980         my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
1981         unless ($self->is_reachable($url)) {
1982             $CPAN::Frontend->myprint("Skipping $url (not reachable)\n");
1983             next;
1984         }
1985         $url .= "/" unless substr($url,-1) eq "/";
1986         $url .= $file;
1987         my($proto,$host,$dir,$getfile);
1988
1989         # Courtesy Mark Conty mark_conty@cargill.com change from
1990         # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
1991         # to
1992         if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
1993             # proto not yet used
1994             ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
1995         } else {
1996             next HOSTHARD; # who said, we could ftp anything except ftp?
1997         }
1998         $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
1999         my($f,$funkyftp);
2000         for $f ('lynx','ncftpget','ncftp') {
2001             next unless exists $CPAN::Config->{$f};
2002             $funkyftp = $CPAN::Config->{$f};
2003             next unless defined $funkyftp;
2004             next if $funkyftp =~ /^\s*$/;
2005             my($want_compressed);
2006             my $aslocal_uncompressed;
2007             ($aslocal_uncompressed = $aslocal) =~ s/\.gz//;
2008             my($source_switch) = "";
2009             $source_switch = " -source" if $funkyftp =~ /\blynx$/;
2010             $source_switch = " -c" if $funkyftp =~ /\bncftp$/;
2011             $CPAN::Frontend->myprint(
2012                   qq[
2013 Trying with "$funkyftp$source_switch" to get
2014     $url
2015 ]);
2016             my($system) = "$funkyftp$source_switch '$url' $devnull > ".
2017                 "$aslocal_uncompressed";
2018             $self->debug("system[$system]") if $CPAN::DEBUG;
2019             my($wstatus);
2020             if (($wstatus = system($system)) == 0
2021                 &&
2022                 -s $aslocal_uncompressed   # lynx returns 0 on my
2023                                            # system even if it fails
2024                ) {
2025                 if ($aslocal_uncompressed ne $aslocal) {
2026                   # test gzip integrity
2027                   if (
2028                       CPAN::Tarzip->gtest($aslocal_uncompressed)
2029                      ) {
2030                     rename $aslocal_uncompressed, $aslocal;
2031                   } else {
2032                     CPAN::Tarzip->gzip($aslocal_uncompressed,
2033                                      "$aslocal_uncompressed.gz");
2034                   }
2035                 }
2036                 $Thesite = $i;
2037                 return $aslocal;
2038             } elsif ($url !~ /\.gz$/) {
2039               unlink $aslocal_uncompressed if
2040                   -f $aslocal_uncompressed && -s _ == 0;
2041               my $gz = "$aslocal.gz";
2042               my $gzurl = "$url.gz";
2043               $CPAN::Frontend->myprint(
2044                       qq[
2045 Trying with "$funkyftp$source_switch" to get
2046   $url.gz
2047 ]);
2048               my($system) = "$funkyftp$source_switch '$url.gz' $devnull > ".
2049                   "$aslocal_uncompressed.gz";
2050               $self->debug("system[$system]") if $CPAN::DEBUG;
2051               my($wstatus);
2052               if (($wstatus = system($system)) == 0
2053                   &&
2054                   -s "$aslocal_uncompressed.gz"
2055                  ) {
2056                 # test gzip integrity
2057                 if (CPAN::Tarzip->gtest("$aslocal_uncompressed.gz")) {
2058                   CPAN::Tarzip->gunzip("$aslocal_uncompressed.gz",
2059                                        $aslocal);
2060                 } else {
2061                   rename $aslocal_uncompressed, $aslocal;
2062                 }
2063                 $Thesite = $i;
2064                 return $aslocal;
2065               } else {
2066                 unlink "$aslocal_uncompressed.gz" if
2067                     -f "$aslocal_uncompressed.gz";
2068               }
2069             } else {
2070                 my $estatus = $wstatus >> 8;
2071                 my $size = -f $aslocal ? ", left\n$aslocal with size ".-s _ : "";
2072                 $CPAN::Frontend->myprint(qq{
2073 System call "$system"
2074 returned status $estatus (wstat $wstatus)$size
2075 });
2076             }
2077         }
2078     }
2079 }
2080
2081 sub hosthardest {
2082     my($self,$host_seq,$file,$aslocal) = @_;
2083
2084     my($i);
2085     my($aslocal_dir) = File::Basename::dirname($aslocal);
2086     File::Path::mkpath($aslocal_dir);
2087   HOSTHARDEST: for $i (@$host_seq) {
2088         unless (length $CPAN::Config->{'ftp'}) {
2089             $CPAN::Frontend->myprint("No external ftp command available\n\n");
2090             last HOSTHARDEST;
2091         }
2092         my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2093         unless ($self->is_reachable($url)) {
2094             $CPAN::Frontend->myprint("Skipping $url (not reachable)\n");
2095             next;
2096         }
2097         $url .= "/" unless substr($url,-1) eq "/";
2098         $url .= $file;
2099         $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
2100         unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2101             next;
2102         }
2103         my($host,$dir,$getfile) = ($1,$2,$3);
2104         my($netrcfile,$fh);
2105         my $timestamp = 0;
2106         my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
2107            $ctime,$blksize,$blocks) = stat($aslocal);
2108         $timestamp = $mtime ||= 0;
2109         my($netrc) = CPAN::FTP::netrc->new;
2110         my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
2111         my $targetfile = File::Basename::basename($aslocal);
2112         my(@dialog);
2113         push(
2114              @dialog,
2115              "lcd $aslocal_dir",
2116              "cd /",
2117              map("cd $_", split "/", $dir), # RFC 1738
2118              "bin",
2119              "get $getfile $targetfile",
2120              "quit"
2121             );
2122         if (! $netrc->netrc) {
2123             CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
2124         } elsif ($netrc->hasdefault || $netrc->contains($host)) {
2125             CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
2126                                 $netrc->hasdefault,
2127                                 $netrc->contains($host))) if $CPAN::DEBUG;
2128             if ($netrc->protected) {
2129                 $CPAN::Frontend->myprint(qq{
2130   Trying with external ftp to get
2131     $url
2132   As this requires some features that are not thoroughly tested, we\'re
2133   not sure, that we get it right....
2134
2135 }
2136                      );
2137                 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose $host",
2138                                 @dialog);
2139                 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2140                  $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2141                 $mtime ||= 0;
2142                 if ($mtime > $timestamp) {
2143                     $CPAN::Frontend->myprint("GOT $aslocal\n");
2144                     $Thesite = $i;
2145                     return $aslocal;
2146                 } else {
2147                     $CPAN::Frontend->myprint("Hmm... Still failed!\n");
2148                 }
2149             } else {
2150                 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
2151                                         qq{correctly protected.\n});
2152             }
2153         } else {
2154             $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
2155   nor does it have a default entry\n");
2156         }
2157
2158         # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
2159         # then and login manually to host, using e-mail as
2160         # password.
2161         $CPAN::Frontend->myprint(qq{Issuing "$CPAN::Config->{'ftp'}$verbose -n"\n});
2162         unshift(
2163                 @dialog,
2164                 "open $host",
2165                 "user anonymous $Config::Config{'cf_email'}"
2166                );
2167         $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose -n", @dialog);
2168         ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2169          $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2170         $mtime ||= 0;
2171         if ($mtime > $timestamp) {
2172             $CPAN::Frontend->myprint("GOT $aslocal\n");
2173             $Thesite = $i;
2174             return $aslocal;
2175         } else {
2176             $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
2177         }
2178         $CPAN::Frontend->myprint("Can't access URL $url.\n\n");
2179         sleep 2;
2180     }
2181 }
2182
2183 sub talk_ftp {
2184     my($self,$command,@dialog) = @_;
2185     my $fh = FileHandle->new;
2186     $fh->open("|$command") or die "Couldn't open ftp: $!";
2187     foreach (@dialog) { $fh->print("$_\n") }
2188     $fh->close;         # Wait for process to complete
2189     my $wstatus = $?;
2190     my $estatus = $wstatus >> 8;
2191     $CPAN::Frontend->myprint(qq{
2192 Subprocess "|$command"
2193   returned status $estatus (wstat $wstatus)
2194 }) if $wstatus;
2195 }
2196
2197 # find2perl needs modularization, too, all the following is stolen
2198 # from there
2199 # CPAN::FTP::ls
2200 sub ls {
2201     my($self,$name) = @_;
2202     my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
2203      $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
2204
2205     my($perms,%user,%group);
2206     my $pname = $name;
2207
2208     if ($blocks) {
2209         $blocks = int(($blocks + 1) / 2);
2210     }
2211     else {
2212         $blocks = int(($sizemm + 1023) / 1024);
2213     }
2214
2215     if    (-f _) { $perms = '-'; }
2216     elsif (-d _) { $perms = 'd'; }
2217     elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
2218     elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
2219     elsif (-p _) { $perms = 'p'; }
2220     elsif (-S _) { $perms = 's'; }
2221     else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
2222
2223     my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
2224     my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
2225     my $tmpmode = $mode;
2226     my $tmp = $rwx[$tmpmode & 7];
2227     $tmpmode >>= 3;
2228     $tmp = $rwx[$tmpmode & 7] . $tmp;
2229     $tmpmode >>= 3;
2230     $tmp = $rwx[$tmpmode & 7] . $tmp;
2231     substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
2232     substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
2233     substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
2234     $perms .= $tmp;
2235
2236     my $user = $user{$uid} || $uid;   # too lazy to implement lookup
2237     my $group = $group{$gid} || $gid;
2238
2239     my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
2240     my($timeyear);
2241     my($moname) = $moname[$mon];
2242     if (-M _ > 365.25 / 2) {
2243         $timeyear = $year + 1900;
2244     }
2245     else {
2246         $timeyear = sprintf("%02d:%02d", $hour, $min);
2247     }
2248
2249     sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
2250             $ino,
2251                  $blocks,
2252                       $perms,
2253                             $nlink,
2254                                 $user,
2255                                      $group,
2256                                           $sizemm,
2257                                               $moname,
2258                                                  $mday,
2259                                                      $timeyear,
2260                                                          $pname;
2261 }
2262
2263 package CPAN::FTP::netrc;
2264
2265 sub new {
2266     my($class) = @_;
2267     my $file = MM->catfile($ENV{HOME},".netrc");
2268
2269     my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2270        $atime,$mtime,$ctime,$blksize,$blocks)
2271         = stat($file);
2272     $mode ||= 0;
2273     my $protected = 0;
2274
2275     my($fh,@machines,$hasdefault);
2276     $hasdefault = 0;
2277     $fh = FileHandle->new or die "Could not create a filehandle";
2278
2279     if($fh->open($file)){
2280         $protected = ($mode & 077) == 0;
2281         local($/) = "";
2282       NETRC: while (<$fh>) {
2283             my(@tokens) = split " ", $_;
2284           TOKEN: while (@tokens) {
2285                 my($t) = shift @tokens;
2286                 if ($t eq "default"){
2287                     $hasdefault++;
2288                     last NETRC;
2289                 }
2290                 last TOKEN if $t eq "macdef";
2291                 if ($t eq "machine") {
2292                     push @machines, shift @tokens;
2293                 }
2294             }
2295         }
2296     } else {
2297         $file = $hasdefault = $protected = "";
2298     }
2299
2300     bless {
2301            'mach' => [@machines],
2302            'netrc' => $file,
2303            'hasdefault' => $hasdefault,
2304            'protected' => $protected,
2305           }, $class;
2306 }
2307
2308 sub hasdefault { shift->{'hasdefault'} }
2309 sub netrc      { shift->{'netrc'}      }
2310 sub protected  { shift->{'protected'}  }
2311 sub contains {
2312     my($self,$mach) = @_;
2313     for ( @{$self->{'mach'}} ) {
2314         return 1 if $_ eq $mach;
2315     }
2316     return 0;
2317 }
2318
2319 package CPAN::Complete;
2320
2321 #-> sub CPAN::Complete::cpl ;
2322 sub cpl {
2323     my($word,$line,$pos) = @_;
2324     $word ||= "";
2325     $line ||= "";
2326     $pos ||= 0;
2327     CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2328     $line =~ s/^\s*//;
2329     if ($line =~ s/^(force\s*)//) {
2330         $pos -= length($1);
2331     }
2332     my @return;
2333     if ($pos == 0) {
2334         @return = grep(
2335                        /^$word/,
2336                        sort qw(
2337                                ! a b d h i m o q r u autobundle clean
2338                                make test install force reload look
2339                               )
2340                       );
2341     } elsif ( $line !~ /^[\!abdhimorutl]/ ) {
2342         @return = ();
2343     } elsif ($line =~ /^a\s/) {
2344         @return = cplx('CPAN::Author',$word);
2345     } elsif ($line =~ /^b\s/) {
2346         @return = cplx('CPAN::Bundle',$word);
2347     } elsif ($line =~ /^d\s/) {
2348         @return = cplx('CPAN::Distribution',$word);
2349     } elsif ($line =~ /^([mru]|make|clean|test|install|readme|look)\s/ ) {
2350         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
2351     } elsif ($line =~ /^i\s/) {
2352         @return = cpl_any($word);
2353     } elsif ($line =~ /^reload\s/) {
2354         @return = cpl_reload($word,$line,$pos);
2355     } elsif ($line =~ /^o\s/) {
2356         @return = cpl_option($word,$line,$pos);
2357     } else {
2358         @return = ();
2359     }
2360     return @return;
2361 }
2362
2363 #-> sub CPAN::Complete::cplx ;
2364 sub cplx {
2365     my($class, $word) = @_;
2366     grep /^\Q$word\E/, map { $_->id } $CPAN::META->all($class);
2367 }
2368
2369 #-> sub CPAN::Complete::cpl_any ;
2370 sub cpl_any {
2371     my($word) = shift;
2372     return (
2373             cplx('CPAN::Author',$word),
2374             cplx('CPAN::Bundle',$word),
2375             cplx('CPAN::Distribution',$word),
2376             cplx('CPAN::Module',$word),
2377            );
2378 }
2379
2380 #-> sub CPAN::Complete::cpl_reload ;
2381 sub cpl_reload {
2382     my($word,$line,$pos) = @_;
2383     $word ||= "";
2384     my(@words) = split " ", $line;
2385     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2386     my(@ok) = qw(cpan index);
2387     return @ok if @words == 1;
2388     return grep /^\Q$word\E/, @ok if @words == 2 && $word;
2389 }
2390
2391 #-> sub CPAN::Complete::cpl_option ;
2392 sub cpl_option {
2393     my($word,$line,$pos) = @_;
2394     $word ||= "";
2395     my(@words) = split " ", $line;
2396     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2397     my(@ok) = qw(conf debug);
2398     return @ok if @words == 1;
2399     return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
2400     if (0) {
2401     } elsif ($words[1] eq 'index') {
2402         return ();
2403     } elsif ($words[1] eq 'conf') {
2404         return CPAN::Config::cpl(@_);
2405     } elsif ($words[1] eq 'debug') {
2406         return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all';
2407     }
2408 }
2409
2410 package CPAN::Index;
2411
2412 #-> sub CPAN::Index::force_reload ;
2413 sub force_reload {
2414     my($class) = @_;
2415     $CPAN::Index::last_time = 0;
2416     $class->reload(1);
2417 }
2418
2419 #-> sub CPAN::Index::reload ;
2420 sub reload {
2421     my($cl,$force) = @_;
2422     my $time = time;
2423
2424     # XXX check if a newer one is available. (We currently read it
2425     # from time to time)
2426     for ($CPAN::Config->{index_expire}) {
2427         $_ = 0.001 unless $_ > 0.001;
2428     }
2429     return if $last_time + $CPAN::Config->{index_expire}*86400 > $time
2430         and ! $force;
2431     my($debug,$t2);
2432     $last_time = $time;
2433
2434     my $needshort = $^O eq "dos";
2435
2436     $cl->rd_authindex($cl->reload_x(
2437                                     "authors/01mailrc.txt.gz",
2438                                     $needshort ? "01mailrc.gz" : "",
2439                                     $force));
2440     $t2 = time;
2441     $debug = "timing reading 01[".($t2 - $time)."]";
2442     $time = $t2;
2443     return if $CPAN::Signal; # this is sometimes lengthy
2444     $cl->rd_modpacks($cl->reload_x(
2445                                    "modules/02packages.details.txt.gz",
2446                                    $needshort ? "02packag.gz" : "",
2447                                    $force));
2448     $t2 = time;
2449     $debug .= "02[".($t2 - $time)."]";
2450     $time = $t2;
2451     return if $CPAN::Signal; # this is sometimes lengthy
2452     $cl->rd_modlist($cl->reload_x(
2453                                   "modules/03modlist.data.gz",
2454                                   $needshort ? "03mlist.gz" : "",
2455                                   $force));
2456     $t2 = time;
2457     $debug .= "03[".($t2 - $time)."]";
2458     $time = $t2;
2459     CPAN->debug($debug) if $CPAN::DEBUG;
2460 }
2461
2462 #-> sub CPAN::Index::reload_x ;
2463 sub reload_x {
2464     my($cl,$wanted,$localname,$force) = @_;
2465     $force |= 2; # means we're dealing with an index here
2466     CPAN::Config->load; # we should guarantee loading wherever we rely
2467                         # on Config XXX
2468     $localname ||= $wanted;
2469     my $abs_wanted = MM->catfile($CPAN::Config->{'keep_source_where'},
2470                                    $localname);
2471     if (
2472         -f $abs_wanted &&
2473         -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
2474         !($force & 1)
2475        ) {
2476         my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
2477         $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
2478                    qq{day$s. I\'ll use that.});
2479         return $abs_wanted;
2480     } else {
2481         $force |= 1; # means we're quite serious about it.
2482     }
2483     return CPAN::FTP->localize($wanted,$abs_wanted,$force);
2484 }
2485
2486 #-> sub CPAN::Index::rd_authindex ;
2487 sub rd_authindex {
2488     my($cl,$index_target) = @_;
2489     return unless defined $index_target;
2490     $CPAN::Frontend->myprint("Going to read $index_target\n");
2491 #    my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
2492 #    while ($_ = $fh->READLINE) {
2493     # no strict 'refs';
2494     local(*FH);
2495     tie *FH, CPAN::Tarzip, $index_target;
2496     local($/) = "\n";
2497     while (<FH>) {
2498         chomp;
2499         my($userid,$fullname,$email) =
2500             m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
2501         next unless $userid && $fullname && $email;
2502
2503         # instantiate an author object
2504         my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
2505         $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
2506         return if $CPAN::Signal;
2507     }
2508 }
2509
2510 sub userid {
2511   my($self,$dist) = @_;
2512   $dist = $self->{'id'} unless defined $dist;
2513   my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
2514   $ret;
2515 }
2516
2517 #-> sub CPAN::Index::rd_modpacks ;
2518 sub rd_modpacks {
2519     my($cl,$index_target) = @_;
2520     return unless defined $index_target;
2521     $CPAN::Frontend->myprint("Going to read $index_target\n");
2522     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
2523     local($/) = "\n";
2524     while ($_ = $fh->READLINE) {
2525         last if /^\s*$/;
2526     }
2527     while ($_ = $fh->READLINE) {
2528         chomp;
2529         my($mod,$version,$dist) = split;
2530 ###     $version =~ s/^\+//;
2531
2532         # if it is a bundle, instatiate a bundle object
2533         my($bundle,$id,$userid);
2534
2535         if ($mod eq 'CPAN' &&
2536             ! (
2537                CPAN::Queue->exists('Bundle::CPAN') ||
2538                CPAN::Queue->exists('CPAN')
2539               )
2540            ) {
2541             local($^W)= 0;
2542             if ($version > $CPAN::VERSION){
2543                 $CPAN::Frontend->myprint(qq{
2544   There\'s a new CPAN.pm version (v$version) available!
2545   You might want to try
2546     install Bundle::CPAN
2547     reload cpan
2548   without quitting the current session. It should be a seamless upgrade
2549   while we are running...
2550 });
2551                 sleep 2;
2552                 $CPAN::Frontend->myprint(qq{\n});
2553             }
2554             last if $CPAN::Signal;
2555         } elsif ($mod =~ /^Bundle::(.*)/) {
2556             $bundle = $1;
2557         }
2558
2559         if ($bundle){
2560             $id =  $CPAN::META->instance('CPAN::Bundle',$mod);
2561             # warn "made mod[$mod]a bundle";
2562             # Let's make it a module too, because bundles have so much
2563             # in common with modules
2564             $CPAN::META->instance('CPAN::Module',$mod);
2565             # warn "made mod[$mod]a module";
2566
2567 # This "next" makes us faster but if the job is running long, we ignore
2568 # rereads which is bad. So we have to be a bit slower again.
2569 #       } elsif ($CPAN::META->exists('CPAN::Module',$mod)) {
2570 #           next;
2571
2572         }
2573         else {
2574             # instantiate a module object
2575             $id = $CPAN::META->instance('CPAN::Module',$mod);
2576         }
2577
2578         if ($id->cpan_file ne $dist){
2579             $userid = $cl->userid($dist);
2580             $id->set(
2581                      'CPAN_USERID' => $userid,
2582                      'CPAN_VERSION' => $version,
2583                      'CPAN_FILE' => $dist
2584                     );
2585         }
2586
2587         # instantiate a distribution object
2588         unless ($CPAN::META->exists('CPAN::Distribution',$dist)) {
2589             $CPAN::META->instance(
2590                                   'CPAN::Distribution' => $dist
2591                                  )->set(
2592                                         'CPAN_USERID' => $userid
2593                                        );
2594         }
2595
2596         return if $CPAN::Signal;
2597     }
2598     undef $fh;
2599 }
2600
2601 #-> sub CPAN::Index::rd_modlist ;
2602 sub rd_modlist {
2603     my($cl,$index_target) = @_;
2604     return unless defined $index_target;
2605     $CPAN::Frontend->myprint("Going to read $index_target\n");
2606     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
2607     my @eval;
2608     local($/) = "\n";
2609     while ($_ = $fh->READLINE) {
2610         if (/^Date:\s+(.*)/){
2611             return if $date_of_03 eq $1;
2612             ($date_of_03) = $1;
2613         }
2614         last if /^\s*$/;
2615     }
2616     push @eval, $_ while $_ = $fh->READLINE;
2617     undef $fh;
2618     push @eval, q{CPAN::Modulelist->data;};
2619     local($^W) = 0;
2620     my($comp) = Safe->new("CPAN::Safe1");
2621     my($eval) = join("", @eval);
2622     my $ret = $comp->reval($eval);
2623     Carp::confess($@) if $@;
2624     return if $CPAN::Signal;
2625     for (keys %$ret) {
2626         my $obj = $CPAN::META->instance(CPAN::Module,$_);
2627         $obj->set(%{$ret->{$_}});
2628         return if $CPAN::Signal;
2629     }
2630 }
2631
2632 package CPAN::InfoObj;
2633
2634 #-> sub CPAN::InfoObj::new ;
2635 sub new { my $this = bless {}, shift; %$this = @_; $this }
2636
2637 #-> sub CPAN::InfoObj::set ;
2638 sub set {
2639     my($self,%att) = @_;
2640     my(%oldatt) = %$self;
2641     %$self = (%oldatt, %att);
2642 }
2643
2644 #-> sub CPAN::InfoObj::id ;
2645 sub id { shift->{'ID'} }
2646
2647 #-> sub CPAN::InfoObj::as_glimpse ;
2648 sub as_glimpse {
2649     my($self) = @_;
2650     my(@m);
2651     my $class = ref($self);
2652     $class =~ s/^CPAN:://;
2653     push @m, sprintf "%-15s %s\n", $class, $self->{ID};
2654     join "", @m;
2655 }
2656
2657 #-> sub CPAN::InfoObj::as_string ;
2658 sub as_string {
2659     my($self) = @_;
2660     my(@m);
2661     my $class = ref($self);
2662     $class =~ s/^CPAN:://;
2663     push @m, $class, " id = $self->{ID}\n";
2664     for (sort keys %$self) {
2665         next if $_ eq 'ID';
2666         my $extra = "";
2667         if ($_ eq "CPAN_USERID") {
2668           $extra .= " (".$self->author;
2669           my $email; # old perls!
2670           if ($email = $CPAN::META->instance(CPAN::Author,
2671                                                 $self->{$_}
2672                                                )->email) {
2673             $extra .= " <$email>";
2674           } else {
2675             $extra .= " <no email>";
2676           }
2677           $extra .= ")";
2678         }
2679         if (ref($self->{$_}) eq "ARRAY") { # language interface? XXX
2680             push @m, sprintf "    %-12s %s%s\n", $_, "@{$self->{$_}}", $extra;
2681         } else {
2682             push @m, sprintf "    %-12s %s%s\n", $_, $self->{$_}, $extra;
2683         }
2684     }
2685     join "", @m, "\n";
2686 }
2687
2688 #-> sub CPAN::InfoObj::author ;
2689 sub author {
2690     my($self) = @_;
2691     $CPAN::META->instance(CPAN::Author,$self->{CPAN_USERID})->fullname;
2692 }
2693
2694 package CPAN::Author;
2695
2696 #-> sub CPAN::Author::as_glimpse ;
2697 sub as_glimpse {
2698     my($self) = @_;
2699     my(@m);
2700     my $class = ref($self);
2701     $class =~ s/^CPAN:://;
2702     push @m, sprintf "%-15s %s (%s)\n", $class, $self->{ID}, $self->fullname;
2703     join "", @m;
2704 }
2705
2706 # Dead code, I would have liked to have,,, but it was never reached,,,
2707 #sub make {
2708 #    my($self) = @_;
2709 #    return "Don't be silly, you can't make $self->{FULLNAME} ;-)\n";
2710 #}
2711
2712 #-> sub CPAN::Author::fullname ;
2713 sub fullname { shift->{'FULLNAME'} }
2714 *name = \&fullname;
2715 #-> sub CPAN::Author::email ;
2716 sub email    { shift->{'EMAIL'} }
2717
2718 package CPAN::Distribution;
2719
2720 #-> sub CPAN::Distribution::called_for ;
2721 sub called_for {
2722     my($self,$id) = @_;
2723     $self->{'CALLED_FOR'} = $id if defined $id;
2724     return $self->{'CALLED_FOR'};
2725 }
2726
2727 #-> sub CPAN::Distribution::get ;
2728 sub get {
2729     my($self) = @_;
2730   EXCUSE: {
2731         my @e;
2732         exists $self->{'build_dir'} and push @e,
2733             "Unwrapped into directory $self->{'build_dir'}";
2734         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
2735     }
2736     my($local_file);
2737     my($local_wanted) =
2738          MM->catfile(
2739                         $CPAN::Config->{keep_source_where},
2740                         "authors",
2741                         "id",
2742                         split("/",$self->{ID})
2743                        );
2744
2745     $self->debug("Doing localize") if $CPAN::DEBUG;
2746     $local_file =
2747         CPAN::FTP->localize("authors/id/$self->{ID}", $local_wanted)
2748             or $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n");
2749     $self->{localfile} = $local_file;
2750     my $builddir = $CPAN::META->{cachemgr}->dir;
2751     $self->debug("doing chdir $builddir") if $CPAN::DEBUG;
2752     chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
2753     my $packagedir;
2754
2755     $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
2756     if ($CPAN::META->has_inst('MD5')) {
2757         $self->debug("MD5 is installed, verifying");
2758         $self->verifyMD5;
2759     } else {
2760         $self->debug("MD5 is NOT installed");
2761     }
2762     $self->debug("Removing tmp") if $CPAN::DEBUG;
2763     File::Path::rmtree("tmp");
2764     mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
2765     chdir "tmp";
2766     $self->debug("Changed directory to tmp") if $CPAN::DEBUG;
2767     if (! $local_file) {
2768         Carp::croak "bad download, can't do anything :-(\n";
2769     } elsif ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)$/i){
2770         $self->untar_me($local_file);
2771     } elsif ( $local_file =~ /\.zip$/i ) {
2772         $self->unzip_me($local_file);
2773     } elsif ( $local_file =~ /\.pm\.(gz|Z)$/) {
2774         $self->pm2dir_me($local_file);
2775     } else {
2776         $self->{archived} = "NO";
2777     }
2778     chdir "..";
2779     if ($self->{archived} ne 'NO') {
2780         chdir "tmp";
2781         # Let's check if the package has its own directory.
2782         my $dh = DirHandle->new(".") or Carp::croak("Couldn't opendir .: $!");
2783         my @readdir = grep $_ !~ /^\.\.?$/, $dh->read; ### MAC??
2784         $dh->close;
2785         my ($distdir,$packagedir);
2786         if (@readdir == 1 && -d $readdir[0]) {
2787             $distdir = $readdir[0];
2788             $packagedir = MM->catdir($builddir,$distdir);
2789             -d $packagedir and $CPAN::Frontend->myprint("Removing previously used $packagedir\n");
2790             File::Path::rmtree($packagedir);
2791             rename($distdir,$packagedir) or Carp::confess("Couldn't rename $distdir to $packagedir: $!");
2792         } else {
2793             my $pragmatic_dir = $self->{'CPAN_USERID'} . '000';
2794             $pragmatic_dir =~ s/\W_//g;
2795             $pragmatic_dir++ while -d "../$pragmatic_dir";
2796             $packagedir = MM->catdir($builddir,$pragmatic_dir);
2797             File::Path::mkpath($packagedir);
2798             my($f);
2799             for $f (@readdir) { # is already without "." and ".."
2800                 my $to = MM->catdir($packagedir,$f);
2801                 rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
2802             }
2803         }
2804         $self->{'build_dir'} = $packagedir;
2805         chdir "..";
2806
2807         $self->debug("Changed directory to .. (self is $self [".$self->as_string."])")
2808             if $CPAN::DEBUG;
2809         File::Path::rmtree("tmp");
2810         if ($CPAN::Config->{keep_source_where} =~ /^no/i ){
2811             $CPAN::Frontend->myprint("Going to unlink $local_file\n");
2812             unlink $local_file or Carp::carp "Couldn't unlink $local_file";
2813         }
2814         my($makefilepl) = MM->catfile($packagedir,"Makefile.PL");
2815         unless (-f $makefilepl) {
2816           my($configure) = MM->catfile($packagedir,"Configure");
2817           if (-f $configure) {
2818             # do we have anything to do?
2819             $self->{'configure'} = $configure;
2820           } elsif (-f MM->catfile($packagedir,"Makefile")) {
2821             $CPAN::Frontend->myprint(qq{
2822 Package comes with a Makefile and without a Makefile.PL.
2823 We\'ll try to build it with that Makefile then.
2824 });
2825             $self->{writemakefile} = "YES";
2826             sleep 2;
2827           } else {
2828             my $fh = FileHandle->new(">$makefilepl")
2829                 or Carp::croak("Could not open >$makefilepl");
2830             my $cf = $self->called_for || "unknown";
2831             $fh->print(
2832 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
2833 # because there was no Makefile.PL supplied.
2834 # Autogenerated on: }.scalar localtime().qq{
2835
2836 use ExtUtils::MakeMaker;
2837 WriteMakefile(NAME => q[$cf]);
2838
2839 });
2840             $CPAN::Frontend->myprint(qq{Package comes without Makefile.PL.
2841   Writing one on our own (calling it $cf)\n});
2842             }
2843         }
2844     }
2845     return $self;
2846 }
2847
2848 sub untar_me {
2849     my($self,$local_file) = @_;
2850     $self->{archived} = "tar";
2851     if (CPAN::Tarzip->untar($local_file)) {
2852         $self->{unwrapped} = "YES";
2853     } else {
2854         $self->{unwrapped} = "NO";
2855     }
2856 }
2857
2858 sub unzip_me {
2859     my($self,$local_file) = @_;
2860     $self->{archived} = "zip";
2861     my $system = "$CPAN::Config->{unzip} $local_file";
2862     if (system($system) == 0) {
2863         $self->{unwrapped} = "YES";
2864     } else {
2865         $self->{unwrapped} = "NO";
2866     }
2867 }
2868
2869 sub pm2dir_me {
2870     my($self,$local_file) = @_;
2871     $self->{archived} = "pm";
2872     my $to = File::Basename::basename($local_file);
2873     $to =~ s/\.(gz|Z)$//;
2874     if (CPAN::Tarzip->gunzip($local_file,$to)) {
2875         $self->{unwrapped} = "YES";
2876     } else {
2877         $self->{unwrapped} = "NO";
2878     }
2879 }
2880
2881 #-> sub CPAN::Distribution::new ;
2882 sub new {
2883     my($class,%att) = @_;
2884
2885     $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
2886
2887     my $this = { %att };
2888     return bless $this, $class;
2889 }
2890
2891 #-> sub CPAN::Distribution::look ;
2892 sub look {
2893     my($self) = @_;
2894     if (  $CPAN::Config->{'shell'} ) {
2895         $CPAN::Frontend->myprint(qq{
2896 Trying to open a subshell in the build directory...
2897 });
2898     } else {
2899         $CPAN::Frontend->myprint(qq{
2900 Your configuration does not define a value for subshells.
2901 Please define it with "o conf shell <your shell>"
2902 });
2903         return;
2904     }
2905     my $dist = $self->id;
2906     my $dir  = $self->dir or $self->get;
2907     $dir = $self->dir;
2908     my $getcwd;
2909     $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
2910     my $pwd  = CPAN->$getcwd();
2911     chdir($dir);
2912     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
2913     system($CPAN::Config->{'shell'}) == 0
2914         or $CPAN::Frontend->mydie("Subprocess shell error");
2915     chdir($pwd);
2916 }
2917
2918 #-> sub CPAN::Distribution::readme ;
2919 sub readme {
2920     my($self) = @_;
2921     my($dist) = $self->id;
2922     my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
2923     $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
2924     my($local_file);
2925     my($local_wanted) =
2926          MM->catfile(
2927                         $CPAN::Config->{keep_source_where},
2928                         "authors",
2929                         "id",
2930                         split("/","$sans.readme"),
2931                        );
2932     $self->debug("Doing localize") if $CPAN::DEBUG;
2933     $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
2934                                       $local_wanted)
2935         or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
2936     my $fh_pager = FileHandle->new;
2937     local($SIG{PIPE}) = "IGNORE";
2938     $fh_pager->open("|$CPAN::Config->{'pager'}")
2939         or die "Could not open pager $CPAN::Config->{'pager'}: $!";
2940     my $fh_readme = FileHandle->new;
2941     $fh_readme->open($local_file)
2942         or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
2943     $CPAN::Frontend->myprint(qq{
2944 Displaying file
2945   $local_file
2946 with pager "$CPAN::Config->{'pager'}"
2947 });
2948     sleep 2;
2949     $fh_pager->print(<$fh_readme>);
2950 }
2951
2952 #-> sub CPAN::Distribution::verifyMD5 ;
2953 sub verifyMD5 {
2954     my($self) = @_;
2955   EXCUSE: {
2956         my @e;
2957         $self->{MD5_STATUS} ||= "";
2958         $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
2959         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
2960     }
2961     my($lc_want,$lc_file,@local,$basename);
2962     @local = split("/",$self->{ID});
2963     pop @local;
2964     push @local, "CHECKSUMS";
2965     $lc_want =
2966         MM->catfile($CPAN::Config->{keep_source_where},
2967                       "authors", "id", @local);
2968     local($") = "/";
2969     if (
2970         -s $lc_want
2971         &&
2972         $self->MD5_check_file($lc_want)
2973        ) {
2974         return $self->{MD5_STATUS} = "OK";
2975     }
2976     $lc_file = CPAN::FTP->localize("authors/id/@local",
2977                                    $lc_want,1);
2978     unless ($lc_file) {
2979         $local[-1] .= ".gz";
2980         $lc_file = CPAN::FTP->localize("authors/id/@local",
2981                                        "$lc_want.gz",1);
2982         if ($lc_file) {
2983             $lc_file =~ s/\.gz$//;
2984             CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
2985         } else {
2986             return;
2987         }
2988     }
2989     $self->MD5_check_file($lc_file);
2990 }
2991
2992 #-> sub CPAN::Distribution::MD5_check_file ;
2993 sub MD5_check_file {
2994     my($self,$chk_file) = @_;
2995     my($cksum,$file,$basename);
2996     $file = $self->{localfile};
2997     $basename = File::Basename::basename($file);
2998     my $fh = FileHandle->new;
2999     if (open $fh, $chk_file){
3000         local($/);
3001         my $eval = <$fh>;
3002         close $fh;
3003         my($comp) = Safe->new();
3004         $cksum = $comp->reval($eval);
3005         if ($@) {
3006             rename $chk_file, "$chk_file.bad";
3007             Carp::confess($@) if $@;
3008         }
3009     } else {
3010         Carp::carp "Could not open $chk_file for reading";
3011     }
3012
3013     if (exists $cksum->{$basename}{md5}) {
3014         $self->debug("Found checksum for $basename:" .
3015                      "$cksum->{$basename}{md5}\n") if $CPAN::DEBUG;
3016
3017         open($fh, $file);
3018         binmode $fh;
3019         my $eq = $self->eq_MD5($fh,$cksum->{$basename}{'md5'});
3020         $fh->close;
3021         $fh = CPAN::Tarzip->TIEHANDLE($file);
3022
3023         unless ($eq) {
3024           # had to inline it, when I tied it, the tiedness got lost on
3025           # the call to eq_MD5. (Jan 1998)
3026           my $md5 = MD5->new;
3027           my($data,$ref);
3028           $ref = \$data;
3029           while ($fh->READ($ref, 4096)){
3030             $md5->add($data);
3031           }
3032           my $hexdigest = $md5->hexdigest;
3033           $eq += $hexdigest eq $cksum->{$basename}{'md5-ungz'};
3034         }
3035
3036         if ($eq) {
3037           $CPAN::Frontend->myprint("Checksum for $file ok\n");
3038           return $self->{MD5_STATUS} = "OK";
3039         } else {
3040             $CPAN::Frontend->myprint(qq{Checksum mismatch for }.
3041                                      qq{distribution file. }.
3042                                      qq{Please investigate.\n\n}.
3043                                      $self->as_string,
3044                                      $CPAN::META->instance(
3045                                                            'CPAN::Author',
3046                                                            $self->{CPAN_USERID}
3047                                                           )->as_string);
3048             my $wrap = qq{I\'d recommend removing $file. It seems to
3049 be a bogus file. Maybe you have configured your \`urllist\' with a
3050 bad URL. Please check this array with \`o conf urllist\', and
3051 retry.};
3052             $CPAN::Frontend->myprint(Text::Wrap::wrap("","",$wrap));
3053             $CPAN::Frontend->myprint("\n\n");
3054             sleep 3;
3055             return;
3056         }
3057         # close $fh if fileno($fh);
3058     } else {
3059         $self->{MD5_STATUS} ||= "";
3060         if ($self->{MD5_STATUS} eq "NIL") {
3061             $CPAN::Frontend->myprint(qq{
3062 No md5 checksum for $basename in local $chk_file.
3063 Removing $chk_file
3064 });
3065             unlink $chk_file or $CPAN::Frontend->myprint("Could not unlink: $!");
3066             sleep 1;
3067         }
3068         $self->{MD5_STATUS} = "NIL";
3069         return;
3070     }
3071 }
3072
3073 #-> sub CPAN::Distribution::eq_MD5 ;
3074 sub eq_MD5 {
3075     my($self,$fh,$expectMD5) = @_;
3076     my $md5 = MD5->new;
3077     my($data);
3078     while (read($fh, $data, 4096)){
3079       $md5->add($data);
3080     }
3081     # $md5->addfile($fh);
3082     my $hexdigest = $md5->hexdigest;
3083     # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
3084     $hexdigest eq $expectMD5;
3085 }
3086
3087 #-> sub CPAN::Distribution::force ;
3088 sub force {
3089   my($self) = @_;
3090   $self->{'force_update'}++;
3091   for my $att (qw(
3092   MD5_STATUS archived build_dir localfile make install unwrapped
3093   writemakefile have_sponsored
3094  )) {
3095     delete $self->{$att};
3096   }
3097 }
3098
3099 sub isa_perl {
3100   my($self) = @_;
3101   my $file = File::Basename::basename($self->id);
3102   return unless $file =~ m{ ^ perl
3103                             (5)
3104                             ([._-])
3105                             (\d{3}(_[0-4][0-9])?)
3106                             \.tar[._-]gz
3107                             $
3108                           }x;
3109   "$1.$3";
3110 }
3111
3112 #-> sub CPAN::Distribution::perl ;
3113 sub perl {
3114     my($self) = @_;
3115     my($perl) = MM->file_name_is_absolute($^X) ? $^X : "";
3116     my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
3117     my $pwd  = CPAN->$getcwd();
3118     my $candidate = MM->catfile($pwd,$^X);
3119     $perl ||= $candidate if MM->maybe_command($candidate);
3120     unless ($perl) {
3121         my ($component,$perl_name);
3122       DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
3123             PATH_COMPONENT: foreach $component (MM->path(),
3124                                                 $Config::Config{'binexp'}) {
3125                   next unless defined($component) && $component;
3126                   my($abs) = MM->catfile($component,$perl_name);
3127                   if (MM->maybe_command($abs)) {
3128                       $perl = $abs;
3129                       last DIST_PERLNAME;
3130                   }
3131               }
3132           }
3133     }
3134     $perl;
3135 }
3136
3137 #-> sub CPAN::Distribution::make ;
3138 sub make {
3139     my($self) = @_;
3140     $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id);
3141     # Emergency brake if they said install Pippi and get newest perl
3142     if ($self->isa_perl) {
3143       if (
3144           $self->called_for ne $self->id && ! $self->{'force_update'}
3145          ) {
3146         $CPAN::Frontend->mydie(sprintf qq{
3147 The most recent version "%s" of the module "%s"
3148 comes with the current version of perl (%s).
3149 I\'ll build that only if you ask for something like
3150     force install %s
3151 or
3152     install %s
3153 },
3154                                $CPAN::META->instance(
3155                                                      'CPAN::Module',
3156                                                      $self->called_for
3157                                                     )->cpan_version,
3158                                $self->called_for,
3159                                $self->isa_perl,
3160                                $self->called_for,
3161                                $self->id);
3162       }
3163     }
3164     $self->get;
3165   EXCUSE: {
3166         my @e;
3167         $self->{archived} eq "NO" and push @e,
3168         "Is neither a tar nor a zip archive.";
3169
3170         $self->{unwrapped} eq "NO" and push @e,
3171         "had problems unarchiving. Please build manually";
3172
3173         exists $self->{writemakefile} &&
3174             $self->{writemakefile} eq "NO" and push @e,
3175             "Had some problem writing Makefile";
3176
3177         defined $self->{'make'} and push @e,
3178         "Has already been processed within this session";
3179
3180         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
3181     }
3182     $CPAN::Frontend->myprint("\n  CPAN.pm: Going to build ".$self->id."\n\n");
3183     my $builddir = $self->dir;
3184     chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
3185     $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
3186
3187     my $system;
3188     if ($self->{'configure'}) {
3189       $system = $self->{'configure'};
3190     } else {
3191         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
3192         my $switch = "";
3193 # This needs a handler that can be turned on or off:
3194 #       $switch = "-MExtUtils::MakeMaker ".
3195 #           "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
3196 #           if $] > 5.00310;
3197         $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
3198     }
3199     unless (exists $self->{writemakefile}) {
3200         local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
3201         my($ret,$pid);
3202         $@ = "";
3203         if ($CPAN::Config->{inactivity_timeout}) {
3204             eval {
3205                 alarm $CPAN::Config->{inactivity_timeout};
3206                 local $SIG{CHLD} = sub { wait };
3207                 if (defined($pid = fork)) {
3208                     if ($pid) { #parent
3209                         wait;
3210                     } else {    #child
3211                       # note, this exec isn't necessary if
3212                       # inactivity_timeout is 0. On the Mac I'd
3213                       # suggest, we set it always to 0.
3214                       exec $system;
3215                     }
3216                 } else {
3217                     $CPAN::Frontend->myprint("Cannot fork: $!");
3218                     return;
3219                 }
3220             };
3221             alarm 0;
3222             if ($@){
3223                 kill 9, $pid;
3224                 waitpid $pid, 0;
3225                 $CPAN::Frontend->myprint($@);
3226                 $self->{writemakefile} = "NO - $@";
3227                 $@ = "";
3228                 return;
3229             }
3230         } else {
3231           $ret = system($system);
3232           if ($ret != 0) {
3233             $self->{writemakefile} = "NO";
3234             return;
3235           }
3236         }
3237         $self->{writemakefile} = "YES";
3238     }
3239     return if $CPAN::Signal;
3240     if (my @prereq = $self->needs_prereq){
3241       my $id = $self->id;
3242       $CPAN::Frontend->myprint("---- Dependencies detected ".
3243                                "during [$id] -----\n");
3244
3245       for my $p (@prereq) {
3246         $CPAN::Frontend->myprint("    $p\n");
3247       }
3248       sleep 2;
3249       my $follow = 0;
3250       if ($CPAN::Config->{prerequisites_policy} eq "follow") {
3251         $follow = 1;
3252       } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
3253         require ExtUtils::MakeMaker;
3254         my $answer = ExtUtils::MakeMaker::prompt(
3255 "Shall I follow them and prepend them to the queue
3256 of modules we are processing right now?", "yes");
3257         $follow = $answer =~ /^\s*y/i;
3258       }
3259       if ($follow) {
3260         CPAN::Queue->jumpqueue(@prereq,$id); # requeue yourself
3261         return;
3262       }
3263     }
3264     $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
3265     if (system($system) == 0) {
3266          $CPAN::Frontend->myprint("  $system -- OK\n");
3267          $self->{'make'} = "YES";
3268     } else {
3269          $self->{writemakefile} = "YES";
3270          $self->{'make'} = "NO";
3271          $CPAN::Frontend->myprint("  $system -- NOT OK\n");
3272     }
3273 }
3274
3275 #-> sub CPAN::Distribution::needs_prereq ;
3276 sub needs_prereq {
3277   my($self) = @_;
3278   return unless -f "Makefile"; # we cannot say much
3279   my $fh = FileHandle->new("<Makefile") or
3280       $CPAN::Frontend->mydie("Couldn't open Makefile: $!");
3281   local($/) = "\n";
3282   my($v);
3283   while (<$fh>) {
3284     last if ($v) = m| ^ \# \s+ ( \d+\.\d+ ) .* Revision: |x;
3285   }
3286
3287   my(@p,@need);
3288   if (1) { # probably all versions of MakeMaker ever so far
3289     while (<$fh>) {
3290       last if /MakeMaker post_initialize section/;
3291       my($p) = m{^[\#]
3292                  \s+PREREQ_PM\s+=>\s+(.+)
3293                  }x;
3294       next unless $p;
3295       # warn "Found prereq expr[$p]";
3296
3297       while ( $p =~ m/(?:\s)([\w\:]+)=>q\[.*?\],?/g ){
3298         push @p, $1;
3299       }
3300       last;
3301     }
3302   } else { # MakeMaker after a patch I suggested. Let's wait and see
3303     while (<$fh>) {
3304       last if /MakeMaker post_initialize section/;
3305       my($p) = m|\# prerequisite (\S+).+not found|;
3306       next unless $p;
3307       push @p, $p;
3308     }
3309   }
3310   for my $p (@p) {
3311     unless ($CPAN::META->instance("CPAN::Module",$p)->inst_file){
3312       if ($self->{'have_sponsored'}{$p}++) {
3313         # We have already sponsored it and for some reason it's still
3314         # not available. So we do nothing. Or what should we do?
3315       } else {
3316         # warn "----- Protegere $p -----";
3317         push @need, $p;
3318         # CPAN::Queue->jumpqueue($p);
3319         # $ret++;
3320       }
3321     }
3322   }
3323   return @need;
3324 }
3325
3326 #-> sub CPAN::Distribution::test ;
3327 sub test {
3328     my($self) = @_;
3329     $self->make;
3330     return if $CPAN::Signal;
3331     $CPAN::Frontend->myprint("Running make test\n");
3332   EXCUSE: {
3333         my @e;
3334         exists $self->{'make'} or push @e,
3335         "Make had some problems, maybe interrupted? Won't test";
3336
3337         exists $self->{'make'} and
3338             $self->{'make'} eq 'NO' and
3339                 push @e, "Oops, make had returned bad status";
3340
3341         exists $self->{'build_dir'} or push @e, "Has no own directory";
3342         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
3343     }
3344     chdir $self->{'build_dir'} or
3345         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
3346     $self->debug("Changed directory to $self->{'build_dir'}")
3347         if $CPAN::DEBUG;
3348     my $system = join " ", $CPAN::Config->{'make'}, "test";
3349     if (system($system) == 0) {
3350          $CPAN::Frontend->myprint("  $system -- OK\n");
3351          $self->{'make_test'} = "YES";
3352     } else {
3353          $self->{'make_test'} = "NO";
3354          $CPAN::Frontend->myprint("  $system -- NOT OK\n");
3355     }
3356 }
3357
3358 #-> sub CPAN::Distribution::clean ;
3359 sub clean {
3360     my($self) = @_;
3361     $CPAN::Frontend->myprint("Running make clean\n");
3362   EXCUSE: {
3363         my @e;
3364         exists $self->{'build_dir'} or push @e, "Has no own directory";
3365         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
3366     }
3367     chdir $self->{'build_dir'} or
3368         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
3369     $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
3370     my $system = join " ", $CPAN::Config->{'make'}, "clean";
3371     if (system($system) == 0) {
3372         $CPAN::Frontend->myprint("  $system -- OK\n");
3373         $self->force;
3374     } else {
3375         # Hmmm, what to do if make clean failed?
3376     }
3377 }
3378
3379 #-> sub CPAN::Distribution::install ;
3380 sub install {
3381     my($self) = @_;
3382     $self->test;
3383     return if $CPAN::Signal;
3384     $CPAN::Frontend->myprint("Running make install\n");
3385   EXCUSE: {
3386         my @e;
3387         exists $self->{'build_dir'} or push @e, "Has no own directory";
3388
3389         exists $self->{'make'} or push @e,
3390         "Make had some problems, maybe interrupted? Won't install";
3391
3392         exists $self->{'make'} and
3393             $self->{'make'} eq 'NO' and
3394                 push @e, "Oops, make had returned bad status";
3395
3396         push @e, "make test had returned bad status, ".
3397             "won't install without force"
3398             if exists $self->{'make_test'} and
3399             $self->{'make_test'} eq 'NO' and
3400             ! $self->{'force_update'};
3401
3402         exists $self->{'install'} and push @e,
3403         $self->{'install'} eq "YES" ?
3404             "Already done" : "Already tried without success";
3405
3406         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
3407     }
3408     chdir $self->{'build_dir'} or
3409         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
3410     $self->debug("Changed directory to $self->{'build_dir'}")
3411         if $CPAN::DEBUG;
3412     my $system = join(" ", $CPAN::Config->{'make'},
3413                       "install", $CPAN::Config->{make_install_arg});
3414     my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 ";
3415     my($pipe) = FileHandle->new("$system $stderr |");
3416     my($makeout) = "";
3417     while (<$pipe>){
3418         $CPAN::Frontend->myprint($_);
3419         $makeout .= $_;
3420     }
3421     $pipe->close;
3422     if ($?==0) {
3423          $CPAN::Frontend->myprint("  $system -- OK\n");
3424          return $self->{'install'} = "YES";
3425     } else {
3426          $self->{'install'} = "NO";
3427          $CPAN::Frontend->myprint("  $system -- NOT OK\n");
3428          if ($makeout =~ /permission/s && $> > 0) {
3429              $CPAN::Frontend->myprint(qq{    You may have to su }.
3430                                       qq{to root to install the package\n});
3431          }
3432     }
3433 }
3434
3435 #-> sub CPAN::Distribution::dir ;
3436 sub dir {
3437     shift->{'build_dir'};
3438 }
3439
3440 package CPAN::Bundle;
3441
3442 #-> sub CPAN::Bundle::as_string ;
3443 sub as_string {
3444     my($self) = @_;
3445     $self->contains;
3446     $self->{INST_VERSION} = $self->inst_version;
3447     return $self->SUPER::as_string;
3448 }
3449
3450 #-> sub CPAN::Bundle::contains ;
3451 sub contains {
3452   my($self) = @_;
3453   my($parsefile) = $self->inst_file;
3454   my($id) = $self->id;
3455   $self->debug("parsefile[$parsefile]id[$id]") if $CPAN::DEBUG;
3456   unless ($parsefile) {
3457     # Try to get at it in the cpan directory
3458     $self->debug("no parsefile") if $CPAN::DEBUG;
3459     Carp::confess "I don't know a $id" unless $self->{CPAN_FILE};
3460     my $dist = $CPAN::META->instance('CPAN::Distribution',
3461                                      $self->{CPAN_FILE});
3462     $dist->get;
3463     $self->debug($dist->as_string) if $CPAN::DEBUG;
3464     my($todir) = $CPAN::Config->{'cpan_home'};
3465     my(@me,$from,$to,$me);
3466     @me = split /::/, $self->id;
3467     $me[-1] .= ".pm";
3468     $me = MM->catfile(@me);
3469     $from = $self->find_bundle_file($dist->{'build_dir'},$me);
3470     $to = MM->catfile($todir,$me);
3471     File::Path::mkpath(File::Basename::dirname($to));
3472     File::Copy::copy($from, $to)
3473         or Carp::confess("Couldn't copy $from to $to: $!");
3474     $parsefile = $to;
3475   }
3476   my @result;
3477   my $fh = FileHandle->new;
3478   local $/ = "\n";
3479   open($fh,$parsefile) or die "Could not open '$parsefile': $!";
3480   my $inpod = 0;
3481   $self->debug("parsefile[$parsefile]") if $CPAN::DEBUG;
3482   while (<$fh>) {
3483     $inpod = m/^=(?!head1\s+CONTENTS)/ ? 0 :
3484         m/^=head1\s+CONTENTS/ ? 1 : $inpod;
3485     next unless $inpod;
3486     next if /^=/;
3487     next if /^\s+$/;
3488     chomp;
3489     push @result, (split " ", $_, 2)[0];
3490   }
3491   close $fh;
3492   delete $self->{STATUS};
3493   $self->{CONTAINS} = join ", ", @result;
3494   $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
3495   unless (@result) {
3496     $CPAN::Frontend->mywarn(qq{
3497 The bundle file "$parsefile" may be a broken
3498 bundlefile. It seems not to contain any bundle definition.
3499 Please check the file and if it is bogus, please delete it.
3500 Sorry for the inconvenience.
3501 });
3502   }
3503   @result;
3504 }
3505
3506 #-> sub CPAN::Bundle::find_bundle_file
3507 sub find_bundle_file {
3508     my($self,$where,$what) = @_;
3509     $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
3510 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
3511 ###    my $bu = MM->catfile($where,$what);
3512 ###    return $bu if -f $bu;
3513     my $manifest = MM->catfile($where,"MANIFEST");
3514     unless (-f $manifest) {
3515         require ExtUtils::Manifest;
3516         my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
3517         my $cwd = CPAN->$getcwd();
3518         chdir $where;
3519         ExtUtils::Manifest::mkmanifest();
3520         chdir $cwd;
3521     }
3522     my $fh = FileHandle->new($manifest)
3523         or Carp::croak("Couldn't open $manifest: $!");
3524     local($/) = "\n";
3525     my $what2 = $what;
3526     $what2 =~ s|Bundle/||;
3527     my $bu;
3528     while (<$fh>) {
3529         next if /^\s*\#/;
3530         my($file) = /(\S+)/;
3531         if ($file =~ m|\Q$what\E$|) {
3532             $bu = $file;
3533             # return MM->catfile($where,$bu); # bad
3534             last;
3535         }
3536         # retry if she managed to
3537         # have no Bundle directory
3538         $bu = $file if $file =~ m|\Q$what2\E$|;
3539     }
3540     return MM->catfile($where, $bu) if $bu;
3541     Carp::croak("Couldn't find a Bundle file in $where");
3542 }
3543
3544 #-> sub CPAN::Bundle::inst_file ;
3545 sub inst_file {
3546     my($self) = @_;
3547     my($me,$inst_file);
3548     ($me = $self->id) =~ s/.*://;
3549 ##    my(@me,$inst_file);
3550 ##    @me = split /::/, $self->id;
3551 ##    $me[-1] .= ".pm";
3552     $inst_file = MM->catfile($CPAN::Config->{'cpan_home'},
3553                                       "Bundle", "$me.pm");
3554 ##                                    "Bundle", @me);
3555     return $self->{'INST_FILE'} = $inst_file if -f $inst_file;
3556 #    $inst_file =
3557     $self->SUPER::inst_file;
3558 #    return $self->{'INST_FILE'} = $inst_file if -f $inst_file;
3559 #    return $self->{'INST_FILE'}; # even if undefined?
3560 }
3561
3562 #-> sub CPAN::Bundle::rematein ;
3563 sub rematein {
3564     my($self,$meth) = @_;
3565     $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
3566     my($id) = $self->id;
3567     Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
3568         unless $self->inst_file || $self->{CPAN_FILE};
3569     my($s,%fail);
3570     for $s ($self->contains) {
3571         my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
3572             $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
3573         if ($type eq 'CPAN::Distribution') {
3574             $CPAN::Frontend->mywarn(qq{
3575 The Bundle }.$self->id.qq{ contains
3576 explicitly a file $s.
3577 });
3578             sleep 3;
3579         }
3580         # possibly noisy action:
3581         my $obj = $CPAN::META->instance($type,$s);
3582         $obj->$meth();
3583         my $success = $obj->can("uptodate") ? $obj->uptodate : 0;
3584         $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
3585         $fail{$s} = 1 unless $success;
3586     }
3587     # recap with less noise
3588     if ( $meth eq "install") {
3589         if (%fail) {
3590             $CPAN::Frontend->myprint(qq{\nBundle summary: }.
3591                                      qq{The following items seem to }.
3592                                      qq{have had installation problems:\n});
3593             for $s ($self->contains) {
3594                 $CPAN::Frontend->myprint( "$s " ) if $fail{$s};
3595             }
3596             $CPAN::Frontend->myprint(qq{\n});
3597         } else {
3598             $self->{'install'} = 'YES';
3599         }
3600     }
3601 }
3602
3603 #sub CPAN::Bundle::xs_file
3604 sub xs_file {
3605     # If a bundle contains another that contains an xs_file we have
3606     # here, we just don't bother I suppose
3607     return 0;
3608 }
3609
3610 #-> sub CPAN::Bundle::force ;
3611 sub force   { shift->rematein('force',@_); }
3612 #-> sub CPAN::Bundle::get ;
3613 sub get     { shift->rematein('get',@_); }
3614 #-> sub CPAN::Bundle::make ;
3615 sub make    { shift->rematein('make',@_); }
3616 #-> sub CPAN::Bundle::test ;
3617 sub test    { shift->rematein('test',@_); }
3618 #-> sub CPAN::Bundle::install ;
3619 sub install {
3620   my $self = shift;
3621   $self->rematein('install',@_);
3622 }
3623 #-> sub CPAN::Bundle::clean ;
3624 sub clean   { shift->rematein('clean',@_); }
3625
3626 #-> sub CPAN::Bundle::readme ;
3627 sub readme  {
3628     my($self) = @_;
3629     my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
3630 No File found for bundle } . $self->id . qq{\n}), return;
3631     $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
3632     $CPAN::META->instance('CPAN::Distribution',$file)->readme;
3633 }
3634
3635 package CPAN::Module;
3636
3637 #-> sub CPAN::Module::as_glimpse ;
3638 sub as_glimpse {
3639     my($self) = @_;
3640     my(@m);
3641     my $class = ref($self);
3642     $class =~ s/^CPAN:://;
3643     push @m, sprintf("%-15s %-15s (%s)\n", $class, $self->{ID},
3644                      $self->cpan_file);
3645     join "", @m;
3646 }
3647
3648 #-> sub CPAN::Module::as_string ;
3649 sub as_string {
3650     my($self) = @_;
3651     my(@m);
3652     CPAN->debug($self) if $CPAN::DEBUG;
3653     my $class = ref($self);
3654     $class =~ s/^CPAN:://;
3655     local($^W) = 0;
3656     push @m, $class, " id = $self->{ID}\n";
3657     my $sprintf = "    %-12s %s\n";
3658     push @m, sprintf($sprintf, 'DESCRIPTION', $self->{description})
3659         if $self->{description};
3660     my $sprintf2 = "    %-12s %s (%s)\n";
3661     my($userid);
3662     if ($userid = $self->{'CPAN_USERID'} || $self->{'userid'}){
3663         my $author;
3664         if ($author = CPAN::Shell->expand('Author',$userid)) {
3665           my $email = "";
3666           my $m; # old perls
3667           if ($m = $author->email) {
3668             $email = " <$m>";
3669           }
3670           push @m, sprintf(
3671                            $sprintf2,
3672                            'CPAN_USERID',
3673                            $userid,
3674                            $author->fullname . $email
3675                           );
3676         }
3677     }
3678     push @m, sprintf($sprintf, 'CPAN_VERSION', $self->{CPAN_VERSION})
3679         if $self->{CPAN_VERSION};
3680     push @m, sprintf($sprintf, 'CPAN_FILE', $self->{CPAN_FILE})
3681         if $self->{CPAN_FILE};
3682     my $sprintf3 = "    %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
3683     my(%statd,%stats,%statl,%stati);
3684     @statd{qw,? i c a b R M S,} = qw,unknown idea
3685         pre-alpha alpha beta released mature standard,;
3686     @stats{qw,? m d u n,}       = qw,unknown mailing-list
3687         developer comp.lang.perl.* none,;
3688     @statl{qw,? p c + o h,}       = qw,unknown perl C C++ other hybrid,;
3689     @stati{qw,? f r O h,}         = qw,unknown functions
3690         references+ties object-oriented hybrid,;
3691     $statd{' '} = 'unknown';
3692     $stats{' '} = 'unknown';
3693     $statl{' '} = 'unknown';
3694     $stati{' '} = 'unknown';
3695     push @m, sprintf(
3696                      $sprintf3,
3697                      'DSLI_STATUS',
3698                      $self->{statd},
3699                      $self->{stats},
3700                      $self->{statl},
3701                      $self->{stati},
3702                      $statd{$self->{statd}},
3703                      $stats{$self->{stats}},
3704                      $statl{$self->{statl}},
3705                      $stati{$self->{stati}}
3706                     ) if $self->{statd};
3707     my $local_file = $self->inst_file;
3708     if ($local_file) {
3709       $self->{MANPAGE} ||= $self->manpage_headline($local_file);
3710     }
3711     my($item);
3712     for $item (qw/MANPAGE CONTAINS/) {
3713         push @m, sprintf($sprintf, $item, $self->{$item})
3714             if exists $self->{$item};
3715     }
3716     push @m, sprintf($sprintf, 'INST_FILE',
3717                      $local_file || "(not installed)");
3718     push @m, sprintf($sprintf, 'INST_VERSION',
3719                      $self->inst_version) if $local_file;
3720     join "", @m, "\n";
3721 }
3722
3723 sub manpage_headline {
3724   my($self,$local_file) = @_;
3725   my(@local_file) = $local_file;
3726   $local_file =~ s/\.pm$/.pod/;
3727   push @local_file, $local_file;
3728   my(@result,$locf);
3729   for $locf (@local_file) {
3730     next unless -f $locf;
3731     my $fh = FileHandle->new($locf)
3732         or $Carp::Frontend->mydie("Couldn't open $locf: $!");
3733     my $inpod = 0;
3734     local $/ = "\n";
3735     while (<$fh>) {
3736       $inpod = m/^=(?!head1\s+NAME)/ ? 0 :
3737           m/^=head1\s+NAME/ ? 1 : $inpod;
3738       next unless $inpod;
3739       next if /^=/;
3740       next if /^\s+$/;
3741       chomp;
3742       push @result, $_;
3743     }
3744     close $fh;
3745     last if @result;
3746   }
3747   join " ", @result;
3748 }
3749
3750 #-> sub CPAN::Module::cpan_file ;
3751 sub cpan_file    {
3752     my $self = shift;
3753     CPAN->debug($self->id) if $CPAN::DEBUG;
3754     unless (defined $self->{'CPAN_FILE'}) {
3755         CPAN::Index->reload;
3756     }
3757     if (exists $self->{'CPAN_FILE'} && defined $self->{'CPAN_FILE'}){
3758         return $self->{'CPAN_FILE'};
3759     } elsif (exists $self->{'userid'} && defined $self->{'userid'}) {
3760         my $fullname = $CPAN::META->instance(CPAN::Author,
3761                                       $self->{'userid'})->fullname;
3762         my $email = $CPAN::META->instance(CPAN::Author,
3763                                       $self->{'userid'})->email;
3764         unless (defined $fullname && defined $email) {
3765             return "Contact Author $self->{userid} (Try ``a $self->{userid}'')";
3766         }
3767         return "Contact Author $fullname <$email>";
3768     } else {
3769         return "N/A";
3770     }
3771 }
3772
3773 *name = \&cpan_file;
3774
3775 #-> sub CPAN::Module::cpan_version ;
3776 sub cpan_version {
3777     my $self = shift;
3778     $self->{'CPAN_VERSION'} = 'undef'
3779         unless defined $self->{'CPAN_VERSION'}; # I believe this is
3780                                                 # always a bug in the
3781                                                 # index and should be
3782                                                 # reported as such,
3783                                                 # but usually I find
3784                                                 # out such an error
3785                                                 # and do not want to
3786                                                 # provoke too many
3787                                                 # bugreports
3788     $self->{'CPAN_VERSION'};
3789 }
3790
3791 #-> sub CPAN::Module::force ;
3792 sub force {
3793     my($self) = @_;
3794     $self->{'force_update'}++;
3795 }
3796
3797 #-> sub CPAN::Module::rematein ;
3798 sub rematein {
3799     my($self,$meth) = @_;
3800     $self->debug($self->id) if $CPAN::DEBUG;
3801     my $cpan_file = $self->cpan_file;
3802     if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
3803       $CPAN::Frontend->mywarn(sprintf qq{
3804   The module %s isn\'t available on CPAN.
3805
3806   Either the module has not yet been uploaded to CPAN, or it is
3807   temporary unavailable. Please contact the author to find out
3808   more about the status. Try ``i %s''.
3809 },
3810                               $self->id,
3811                               $self->id,
3812                              );
3813       return;
3814     }
3815     my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
3816     $pack->called_for($self->id);
3817     $pack->force if exists $self->{'force_update'};
3818     $pack->$meth();
3819     delete $self->{'force_update'};
3820 }
3821
3822 #-> sub CPAN::Module::readme ;
3823 sub readme { shift->rematein('readme') }
3824 #-> sub CPAN::Module::look ;
3825 sub look { shift->rematein('look') }
3826 #-> sub CPAN::Module::get ;
3827 sub get    { shift->rematein('get',@_); }
3828 #-> sub CPAN::Module::make ;
3829 sub make   { shift->rematein('make') }
3830 #-> sub CPAN::Module::test ;
3831 sub test   { shift->rematein('test') }
3832 #-> sub CPAN::Module::uptodate ;
3833 sub uptodate {
3834     my($self) = @_;
3835     my($latest) = $self->cpan_version;
3836     $latest ||= 0;
3837     my($inst_file) = $self->inst_file;
3838     my($have) = 0;
3839     if (defined $inst_file) {
3840         $have = $self->inst_version;
3841     }
3842     if (1){ # A block for scoping $^W, the if is just for the visual
3843             # appeal
3844         local($^W)=0;
3845         if ($inst_file
3846             &&
3847             $have >= $latest
3848            ) {
3849             return 1;
3850         }
3851     }
3852     return;
3853 }
3854 #-> sub CPAN::Module::install ;
3855 sub install {
3856     my($self) = @_;
3857     my($doit) = 0;
3858     if ($self->uptodate
3859         &&
3860         not exists $self->{'force_update'}
3861        ) {
3862         $CPAN::Frontend->myprint( $self->id. " is up to date.\n");
3863     } else {
3864         $doit = 1;
3865     }
3866     $self->rematein('install') if $doit;
3867 }
3868 #-> sub CPAN::Module::clean ;
3869 sub clean  { shift->rematein('clean') }
3870
3871 #-> sub CPAN::Module::inst_file ;
3872 sub inst_file {
3873     my($self) = @_;
3874     my($dir,@packpath);
3875     @packpath = split /::/, $self->{ID};
3876     $packpath[-1] .= ".pm";
3877     foreach $dir (@INC) {
3878         my $pmfile = MM->catfile($dir,@packpath);
3879         if (-f $pmfile){
3880             return $pmfile;
3881         }
3882     }
3883     return;
3884 }
3885
3886 #-> sub CPAN::Module::xs_file ;
3887 sub xs_file {
3888     my($self) = @_;
3889     my($dir,@packpath);
3890     @packpath = split /::/, $self->{ID};
3891     push @packpath, $packpath[-1];
3892     $packpath[-1] .= "." . $Config::Config{'dlext'};
3893     foreach $dir (@INC) {
3894         my $xsfile = MM->catfile($dir,'auto',@packpath);
3895         if (-f $xsfile){
3896             return $xsfile;
3897         }
3898     }
3899     return;
3900 }
3901
3902 #-> sub CPAN::Module::inst_version ;
3903 sub inst_version {
3904     my($self) = @_;
3905     my $parsefile = $self->inst_file or return;
3906     local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
3907     # warn "HERE";
3908     my $have = MM->parse_version($parsefile) || "undef";
3909     $have =~ s/\s+//g;
3910     $have;
3911 }
3912
3913 package CPAN::Tarzip;
3914
3915 sub gzip {
3916   my($class,$read,$write) = @_;
3917   if ($CPAN::META->has_inst("Compress::Zlib")) {
3918     my($buffer,$fhw);
3919     $fhw = FileHandle->new($read)
3920         or $CPAN::Frontend->mydie("Could not open $read: $!");
3921     my $gz = Compress::Zlib::gzopen($write, "wb")
3922         or $CPAN::Frontend->mydie("Cannot gzopen $write: $!\n");
3923     $gz->gzwrite($buffer)
3924         while read($fhw,$buffer,4096) > 0 ;
3925     $gz->gzclose() ;
3926     $fhw->close;
3927     return 1;
3928   } else {
3929     system("$CPAN::Config->{'gzip'} -c $read > $write")==0;
3930   }
3931 }
3932
3933 sub gunzip {
3934   my($class,$read,$write) = @_;
3935   if ($CPAN::META->has_inst("Compress::Zlib")) {
3936     my($buffer,$fhw);
3937     $fhw = FileHandle->new(">$write")
3938         or $CPAN::Frontend->mydie("Could not open >$write: $!");
3939     my $gz = Compress::Zlib::gzopen($read, "rb")
3940         or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
3941     $fhw->print($buffer)
3942         while $gz->gzread($buffer) > 0 ;
3943     $CPAN::Frontend->mydie("Error reading from $read: $!\n")
3944         if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
3945     $gz->gzclose() ;
3946     $fhw->close;
3947     return 1;
3948   } else {
3949     system("$CPAN::Config->{'gzip'} -dc $read > $write")==0;
3950   }
3951 }
3952
3953 sub gtest {
3954   my($class,$read) = @_;
3955   if ($CPAN::META->has_inst("Compress::Zlib")) {
3956     my($buffer);
3957     my $gz = Compress::Zlib::gzopen($read, "rb")
3958         or $CPAN::Frontend->mydie("Cannot open $read: $!\n");
3959     1 while $gz->gzread($buffer) > 0 ;
3960     $CPAN::Frontend->mydie("Error reading from $read: $!\n")
3961         if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
3962     $gz->gzclose() ;
3963     return 1;
3964   } else {
3965     return system("$CPAN::Config->{'gzip'} -dt $read")==0;
3966   }
3967 }
3968
3969 sub TIEHANDLE {
3970   my($class,$file) = @_;
3971   my $ret;
3972   $class->debug("file[$file]");
3973   if ($CPAN::META->has_inst("Compress::Zlib")) {
3974     my $gz = Compress::Zlib::gzopen($file,"rb") or
3975         die "Could not gzopen $file";
3976     $ret = bless {GZ => $gz}, $class;
3977   } else {
3978     my $pipe = "$CPAN::Config->{'gzip'} --decompress --stdout $file |";
3979     my $fh = FileHandle->new($pipe) or die "Could pipe[$pipe]: $!";
3980     binmode $fh;
3981     $ret = bless {FH => $fh}, $class;
3982   }
3983   $ret;
3984 }
3985
3986 sub READLINE {
3987   my($self) = @_;
3988   if (exists $self->{GZ}) {
3989     my $gz = $self->{GZ};
3990     my($line,$bytesread);
3991     $bytesread = $gz->gzreadline($line);
3992     return undef if $bytesread == 0;
3993     return $line;
3994   } else {
3995     my $fh = $self->{FH};
3996     return scalar <$fh>;
3997   }
3998 }
3999
4000 sub READ {
4001   my($self,$ref,$length,$offset) = @_;
4002   die "read with offset not implemented" if defined $offset;
4003   if (exists $self->{GZ}) {
4004     my $gz = $self->{GZ};
4005     my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
4006     return $byteread;
4007   } else {
4008     my $fh = $self->{FH};
4009     return read($fh,$$ref,$length);
4010   }
4011 }
4012
4013 sub DESTROY {
4014   my($self) = @_;
4015   if (exists $self->{GZ}) {
4016     my $gz = $self->{GZ};
4017     $gz->gzclose();
4018   } else {
4019     my $fh = $self->{FH};
4020     $fh->close;
4021   }
4022   undef $self;
4023 }
4024
4025 sub untar {
4026   my($class,$file) = @_;
4027   # had to disable, because version 0.07 seems to be buggy
4028   if (MM->maybe_command($CPAN::Config->{'gzip'})
4029       &&
4030       MM->maybe_command($CPAN::Config->{'tar'})) {
4031     if ($^O =~ /win/i) { # irgggh
4032         # people find the most curious tar binaries that cannot handle
4033         # pipes
4034         my $system = "$CPAN::Config->{'gzip'} --decompress $file";
4035         if (system($system)==0) {
4036             $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
4037         } else {
4038             $CPAN::Frontend->mydie(
4039                                    qq{Couldn\'t uncompress $file\n}
4040                                   );
4041         }
4042         $file =~ s/\.gz$//;
4043         $system = "$CPAN::Config->{tar} xvf $file";
4044         if (system($system)==0) {
4045             $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
4046         } else {
4047             $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
4048         }
4049         return 1;
4050     } else {
4051         my $system = "$CPAN::Config->{'gzip'} --decompress --stdout " .
4052             "< $file | $CPAN::Config->{tar} xvf -";
4053         return system($system) == 0;
4054     }
4055   } elsif ($CPAN::META->has_inst("Archive::Tar")
4056       &&
4057       $CPAN::META->has_inst("Compress::Zlib") ) {
4058     my $tar = Archive::Tar->new($file,1);
4059     $tar->extract($tar->list_files); # I'm pretty sure we have nothing
4060                                      # that isn't compressed
4061     return 1;
4062   } else {
4063     $CPAN::Frontend->mydie(qq{
4064 CPAN.pm needs either both external programs tar and gzip installed or
4065 both the modules Archive::Tar and Compress::Zlib. Neither prerequisite
4066 is available. Can\'t continue.
4067 });
4068   }
4069 }
4070
4071 package CPAN;
4072
4073 1;
4074
4075 __END__
4076
4077 =head1 NAME
4078
4079 CPAN - query, download and build perl modules from CPAN sites
4080
4081 =head1 SYNOPSIS
4082
4083 Interactive mode:
4084
4085   perl -MCPAN -e shell;
4086
4087 Batch mode:
4088
4089   use CPAN;
4090
4091   autobundle, clean, install, make, recompile, test
4092
4093 =head1 DESCRIPTION
4094
4095 The CPAN module is designed to automate the make and install of perl
4096 modules and extensions. It includes some searching capabilities and
4097 knows how to use Net::FTP or LWP (or lynx or an external ftp client)
4098 to fetch the raw data from the net.
4099
4100 Modules are fetched from one or more of the mirrored CPAN
4101 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
4102 directory.
4103
4104 The CPAN module also supports the concept of named and versioned
4105 'bundles' of modules. Bundles simplify the handling of sets of
4106 related modules. See BUNDLES below.
4107
4108 The package contains a session manager and a cache manager. There is
4109 no status retained between sessions. The session manager keeps track
4110 of what has been fetched, built and installed in the current
4111 session. The cache manager keeps track of the disk space occupied by
4112 the make processes and deletes excess space according to a simple FIFO
4113 mechanism.
4114
4115 For extended searching capabilities there's a plugin for CPAN available,
4116 L<CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine that indexes
4117 all documents available in CPAN authors directories. If C<CPAN::WAIT>
4118 is installed on your system, the interactive shell of <CPAN.pm> will
4119 enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands which send
4120 queries to the WAIT server that has been configured for your
4121 installation.
4122
4123 All other methods provided are accessible in a programmer style and in an
4124 interactive shell style.
4125
4126 =head2 Interactive Mode
4127
4128 The interactive mode is entered by running
4129
4130     perl -MCPAN -e shell
4131
4132 which puts you into a readline interface. You will have the most fun if
4133 you install Term::ReadKey and Term::ReadLine to enjoy both history and
4134 command completion.
4135
4136 Once you are on the command line, type 'h' and the rest should be
4137 self-explanatory.
4138
4139 The most common uses of the interactive modes are
4140
4141 =over 2
4142
4143 =item Searching for authors, bundles, distribution files and modules
4144
4145 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
4146 for each of the four categories and another, C<i> for any of the
4147 mentioned four. Each of the four entities is implemented as a class
4148 with slightly differing methods for displaying an object.
4149
4150 Arguments you pass to these commands are either strings exactly matching
4151 the identification string of an object or regular expressions that are
4152 then matched case-insensitively against various attributes of the
4153 objects. The parser recognizes a regular expression only if you
4154 enclose it between two slashes.
4155
4156 The principle is that the number of found objects influences how an
4157 item is displayed. If the search finds one item, the result is displayed
4158 as object-E<gt>as_string, but if we find more than one, we display
4159 each as object-E<gt>as_glimpse. E.g.
4160
4161     cpan> a ANDK
4162     Author id = ANDK
4163         EMAIL        a.koenig@franz.ww.TU-Berlin.DE
4164         FULLNAME     Andreas König
4165
4166
4167     cpan> a /andk/
4168     Author id = ANDK
4169         EMAIL        a.koenig@franz.ww.TU-Berlin.DE
4170         FULLNAME     Andreas König
4171
4172
4173     cpan> a /and.*rt/
4174     Author          ANDYD (Andy Dougherty)
4175     Author          MERLYN (Randal L. Schwartz)
4176
4177 =item make, test, install, clean  modules or distributions
4178
4179 These commands take any number of arguments and investigate what is
4180 necessary to perform the action. If the argument is a distribution
4181 file name (recognized by embedded slashes), it is processed. If it is a
4182 module, CPAN determines the distribution file in which this module is
4183 included and processes that.
4184
4185 Any C<make> or C<test> are run unconditionally. An
4186
4187   install <distribution_file>
4188
4189 also is run unconditionally. But for
4190
4191   install <module>
4192
4193 CPAN checks if an install is actually needed for it and prints
4194 I<module up to date> in the case that the distribution file containing
4195 the module doesnE<39>t need to be updated.
4196
4197 CPAN also keeps track of what it has done within the current session
4198 and doesnE<39>t try to build a package a second time regardless if it
4199 succeeded or not. The C<force> command takes as a first argument the
4200 method to invoke (currently: C<make>, C<test>, or C<install>) and executes the
4201 command from scratch.
4202
4203 Example:
4204
4205     cpan> install OpenGL
4206     OpenGL is up to date.
4207     cpan> force install OpenGL
4208     Running make
4209     OpenGL-0.4/
4210     OpenGL-0.4/COPYRIGHT
4211     [...]
4212
4213 A C<clean> command results in a
4214
4215   make clean
4216
4217 being executed within the distribution file's working directory.
4218
4219 =item readme, look module or distribution
4220
4221 These two commands take only one argument, be it a module or a
4222 distribution file. C<readme> unconditionally runs, displaying the
4223 README of the associated distribution file. C<Look> gets and
4224 untars (if not yet done) the distribution file, changes to the
4225 appropriate directory and opens a subshell process in that directory.
4226
4227 =item Signals
4228
4229 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
4230 in the cpan-shell it is intended that you can press C<^C> anytime and
4231 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
4232 to clean up and leave the shell loop. You can emulate the effect of a
4233 SIGTERM by sending two consecutive SIGINTs, which usually means by
4234 pressing C<^C> twice.
4235
4236 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
4237 SIGALRM is used during the run of the C<perl Makefile.PL> subprocess.
4238
4239 =back
4240
4241 =head2 CPAN::Shell
4242
4243 The commands that are available in the shell interface are methods in
4244 the package CPAN::Shell. If you enter the shell command, all your
4245 input is split by the Text::ParseWords::shellwords() routine which
4246 acts like most shells do. The first word is being interpreted as the
4247 method to be called and the rest of the words are treated as arguments
4248 to this method. Continuation lines are supported if a line ends with a
4249 literal backslash.
4250
4251 =head2 autobundle
4252
4253 C<autobundle> writes a bundle file into the
4254 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
4255 a list of all modules that are both available from CPAN and currently
4256 installed within @INC. The name of the bundle file is based on the
4257 current date and a counter.
4258
4259 =head2 recompile
4260
4261 recompile() is a very special command in that it takes no argument and
4262 runs the make/test/install cycle with brute force over all installed
4263 dynamically loadable extensions (aka XS modules) with 'force' in
4264 effect. The primary purpose of this command is to finish a network
4265 installation. Imagine, you have a common source tree for two different
4266 architectures. You decide to do a completely independent fresh
4267 installation. You start on one architecture with the help of a Bundle
4268 file produced earlier. CPAN installs the whole Bundle for you, but
4269 when you try to repeat the job on the second architecture, CPAN
4270 responds with a C<"Foo up to date"> message for all modules. So you
4271 invoke CPAN's recompile on the second architecture and youE<39>re done.
4272
4273 Another popular use for C<recompile> is to act as a rescue in case your
4274 perl breaks binary compatibility. If one of the modules that CPAN uses
4275 is in turn depending on binary compatibility (so you cannot run CPAN
4276 commands), then you should try the CPAN::Nox module for recovery.
4277
4278 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
4279
4280 Although it may be considered internal, the class hierarchy does matter
4281 for both users and programmer. CPAN.pm deals with above mentioned four
4282 classes, and all those classes share a set of methods. A classical
4283 single polymorphism is in effect. A metaclass object registers all
4284 objects of all kinds and indexes them with a string. The strings
4285 referencing objects have a separated namespace (well, not completely
4286 separated):
4287
4288          Namespace                         Class
4289
4290    words containing a "/" (slash)      Distribution
4291     words starting with Bundle::          Bundle
4292           everything else            Module or Author
4293
4294 Modules know their associated Distribution objects. They always refer
4295 to the most recent official release. Developers may mark their releases
4296 as unstable development versions (by inserting an underbar into the
4297 visible version number), so the really hottest and newest distribution
4298 file is not always the default.  If a module Foo circulates on CPAN in
4299 both version 1.23 and 1.23_90, CPAN.pm offers a convenient way to
4300 install version 1.23 by saying
4301
4302     install Foo
4303
4304 This would install the complete distribution file (say
4305 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
4306 like to install version 1.23_90, you need to know where the
4307 distribution file resides on CPAN relative to the authors/id/
4308 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
4309 so you would have to say
4310
4311     install BAR/Foo-1.23_90.tar.gz
4312
4313 The first example will be driven by an object of the class
4314 CPAN::Module, the second by an object of class CPAN::Distribution.
4315
4316 =head2 ProgrammerE<39>s interface
4317
4318 If you do not enter the shell, the available shell commands are both
4319 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
4320 functions in the calling package (C<install(...)>).
4321
4322 There's currently only one class that has a stable interface -
4323 CPAN::Shell. All commands that are available in the CPAN shell are
4324 methods of the class CPAN::Shell. Each of the commands that produce
4325 listings of modules (C<r>, C<autobundle>, C<u>) returns a list of the
4326 IDs of all modules within the list.
4327
4328 =over 2
4329
4330 =item expand($type,@things)
4331
4332 The IDs of all objects available within a program are strings that can
4333 be expanded to the corresponding real objects with the
4334 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
4335 list of CPAN::Module objects according to the C<@things> arguments
4336 given. In scalar context it only returns the first element of the
4337 list.
4338
4339 =item Programming Examples
4340
4341 This enables the programmer to do operations that combine
4342 functionalities that are available in the shell.
4343
4344     # install everything that is outdated on my disk:
4345     perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
4346
4347     # install my favorite programs if necessary:
4348     for $mod (qw(Net::FTP MD5 Data::Dumper)){
4349         my $obj = CPAN::Shell->expand('Module',$mod);
4350         $obj->install;
4351     }
4352
4353     # list all modules on my disk that have no VERSION number
4354     for $mod (CPAN::Shell->expand("Module","/./")){
4355         next unless $mod->inst_file;
4356         # MakeMaker convention for undefined $VERSION:
4357         next unless $mod->inst_version eq "undef";
4358         print "No VERSION in ", $mod->id, "\n";
4359     }
4360
4361 =back
4362
4363 =head2 Methods in the four Classes
4364
4365 =head2 Cache Manager
4366
4367 Currently the cache manager only keeps track of the build directory
4368 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
4369 deletes complete directories below C<build_dir> as soon as the size of
4370 all directories there gets bigger than $CPAN::Config->{build_cache}
4371 (in MB). The contents of this cache may be used for later
4372 re-installations that you intend to do manually, but will never be
4373 trusted by CPAN itself. This is due to the fact that the user might
4374 use these directories for building modules on different architectures.
4375
4376 There is another directory ($CPAN::Config->{keep_source_where}) where
4377 the original distribution files are kept. This directory is not
4378 covered by the cache manager and must be controlled by the user. If
4379 you choose to have the same directory as build_dir and as
4380 keep_source_where directory, then your sources will be deleted with
4381 the same fifo mechanism.
4382
4383 =head2 Bundles
4384
4385 A bundle is just a perl module in the namespace Bundle:: that does not
4386 define any functions or methods. It usually only contains documentation.
4387
4388 It starts like a perl module with a package declaration and a $VERSION
4389 variable. After that the pod section looks like any other pod with the
4390 only difference being that I<one special pod section> exists starting with
4391 (verbatim):
4392
4393         =head1 CONTENTS
4394
4395 In this pod section each line obeys the format
4396
4397         Module_Name [Version_String] [- optional text]
4398
4399 The only required part is the first field, the name of a module
4400 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
4401 of the line is optional. The comment part is delimited by a dash just
4402 as in the man page header.
4403
4404 The distribution of a bundle should follow the same convention as
4405 other distributions.
4406
4407 Bundles are treated specially in the CPAN package. If you say 'install
4408 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
4409 the modules in the CONTENTS section of the pod. You can install your
4410 own Bundles locally by placing a conformant Bundle file somewhere into
4411 your @INC path. The autobundle() command which is available in the
4412 shell interface does that for you by including all currently installed
4413 modules in a snapshot bundle file.
4414
4415 =head2 Prerequisites
4416
4417 If you have a local mirror of CPAN and can access all files with
4418 "file:" URLs, then you only need a perl better than perl5.003 to run
4419 this module. Otherwise Net::FTP is strongly recommended. LWP may be
4420 required for non-UNIX systems or if your nearest CPAN site is
4421 associated with an URL that is not C<ftp:>.
4422
4423 If you have neither Net::FTP nor LWP, there is a fallback mechanism
4424 implemented for an external ftp command or for an external lynx
4425 command.
4426
4427 =head2 Finding packages and VERSION
4428
4429 This module presumes that all packages on CPAN
4430
4431 =over 2
4432
4433 =item *
4434
4435 declare their $VERSION variable in an easy to parse manner. This
4436 prerequisite can hardly be relaxed because it consumes far too much
4437 memory to load all packages into the running program just to determine
4438 the $VERSION variable. Currently all programs that are dealing with
4439 version use something like this
4440
4441     perl -MExtUtils::MakeMaker -le \
4442         'print MM->parse_version(shift)' filename
4443
4444 If you are author of a package and wonder if your $VERSION can be
4445 parsed, please try the above method.
4446
4447 =item *
4448
4449 come as compressed or gzipped tarfiles or as zip files and contain a
4450 Makefile.PL (well, we try to handle a bit more, but without much
4451 enthusiasm).
4452
4453 =back
4454
4455 =head2 Debugging
4456
4457 The debugging of this module is pretty difficult, because we have
4458 interferences of the software producing the indices on CPAN, of the
4459 mirroring process on CPAN, of packaging, of configuration, of
4460 synchronicity, and of bugs within CPAN.pm.
4461
4462 In interactive mode you can try "o debug" which will list options for
4463 debugging the various parts of the package. The output may not be very
4464 useful for you as it's just a by-product of my own testing, but if you
4465 have an idea which part of the package may have a bug, it's sometimes
4466 worth to give it a try and send me more specific output. You should
4467 know that "o debug" has built-in completion support.
4468
4469 =head2 Floppy, Zip, Offline Mode
4470
4471 CPAN.pm works nicely without network too. If you maintain machines
4472 that are not networked at all, you should consider working with file:
4473 URLs. Of course, you have to collect your modules somewhere first. So
4474 you might use CPAN.pm to put together all you need on a networked
4475 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
4476 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
4477 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
4478 with this floppy.
4479
4480 =head1 CONFIGURATION
4481
4482 When the CPAN module is installed, a site wide configuration file is
4483 created as CPAN/Config.pm. The default values defined there can be
4484 overridden in another configuration file: CPAN/MyConfig.pm. You can
4485 store this file in $HOME/.cpan/CPAN/MyConfig.pm if you want, because
4486 $HOME/.cpan is added to the search path of the CPAN module before the
4487 use() or require() statements.
4488
4489 Currently the following keys in the hash reference $CPAN::Config are
4490 defined:
4491
4492   build_cache        size of cache for directories to build modules
4493   build_dir          locally accessible directory to build modules
4494   index_expire       after this many days refetch index files
4495   cpan_home          local directory reserved for this package
4496   gzip               location of external program gzip
4497   inactivity_timeout breaks interactive Makefile.PLs after this
4498                      many seconds inactivity. Set to 0 to never break.
4499   inhibit_startup_message
4500                      if true, does not print the startup message
4501   keep_source        keep the source in a local directory?
4502   keep_source_where  directory in which to keep the source (if we do)
4503   make               location of external make program
4504   make_arg           arguments that should always be passed to 'make'
4505   make_install_arg   same as make_arg for 'make install'
4506   makepl_arg         arguments passed to 'perl Makefile.PL'
4507   pager              location of external program more (or any pager)
4508   scan_cache         controls scanning of cache ('atstart' or 'never')
4509   tar                location of external program tar
4510   unzip              location of external program unzip
4511   urllist            arrayref to nearby CPAN sites (or equivalent locations)
4512   wait_list          arrayref to a wait server to try (See CPAN::WAIT)
4513   ftp_proxy,      }  the three usual variables for configuring
4514     http_proxy,   }  proxy requests. Both as CPAN::Config variables
4515     no_proxy      }  and as environment variables configurable.
4516
4517 You can set and query each of these options interactively in the cpan
4518 shell with the command set defined within the C<o conf> command:
4519
4520 =over 2
4521
4522 =item o conf E<lt>scalar optionE<gt>
4523
4524 prints the current value of the I<scalar option>
4525
4526 =item o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>
4527
4528 Sets the value of the I<scalar option> to I<value>
4529
4530 =item o conf E<lt>list optionE<gt>
4531
4532 prints the current value of the I<list option> in MakeMaker's
4533 neatvalue format.
4534
4535 =item o conf E<lt>list optionE<gt> [shift|pop]
4536
4537 shifts or pops the array in the I<list option> variable
4538
4539 =item o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>
4540
4541 works like the corresponding perl commands.
4542
4543 =back
4544
4545 =head2 urllist parameter has CD-ROM support
4546
4547 The C<urllist> parameter of the configuration table contains a list of
4548 URLs that are to be used for downloading. If the list contains any
4549 C<file> URLs, CPAN always tries to get files from there first. This
4550 feature is disabled for index files. So the recommendation for the
4551 owner of a CD-ROM with CPAN contents is: include your local, possibly
4552 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
4553
4554   o conf urllist push file://localhost/CDROM/CPAN
4555
4556 CPAN.pm will then fetch the index files from one of the CPAN sites
4557 that come at the beginning of urllist. It will later check for each
4558 module if there is a local copy of the most recent version.
4559
4560 Another peculiarity of urllist is that the site that we could
4561 successfully fetch the last file from automatically gets a preference
4562 token and is tried as the first site for the next request. So if you
4563 add a new site at runtime it may happen that the previously preferred
4564 site will be tried another time. This means that if you want to disallow
4565 a site for the next transfer, it must be explicitly removed from
4566 urllist.
4567
4568 =head1 SECURITY
4569
4570 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
4571 install foreign, unmasked, unsigned code on your machine. We compare
4572 to a checksum that comes from the net just as the distribution file
4573 itself. If somebody has managed to tamper with the distribution file,
4574 they may have as well tampered with the CHECKSUMS file. Future
4575 development will go towards strong authentification.
4576
4577 =head1 EXPORT
4578
4579 Most functions in package CPAN are exported per default. The reason
4580 for this is that the primary use is intended for the cpan shell or for
4581 oneliners.
4582
4583 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
4584
4585 To populate a freshly installed perl with my favorite modules is pretty
4586 easiest by maintaining a private bundle definition file. To get a useful
4587 blueprint of a bundle definition file, the command autobundle can be used
4588 on the CPAN shell command line. This command writes a bundle definition
4589 file for all modules that re installed for the currently running perl
4590 interpreter. It's recommended to run this command only once and from then
4591 on maintain the file manually under a private name, say
4592 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
4593
4594     cpan> install Bundle::my_bundle
4595
4596 then answer a few questions and then go out.
4597
4598 Maintaining a bundle definition file means to keep track of two things:
4599 dependencies and interactivity. CPAN.pm (currently) does not take into
4600 account dependencies between distributions, so a bundle definition file
4601 should specify distributions that depend on others B<after> the others.
4602 On the other hand, it's a bit annoying that many distributions need some
4603 interactive configuring. So what I try to accomplish in my private bundle
4604 file is to have the packages that need to be configured early in the file
4605 and the gentle ones later, so I can go out after a few minutes and leave
4606 CPAN.pm unattained.
4607
4608 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
4609
4610 Thanks to Graham Barr for contributing the firewall following howto.
4611
4612 Firewalls can be categorized into three basic types.
4613
4614 =over
4615
4616 =item http firewall
4617
4618 This is where the firewall machine runs a web server and to access the
4619 outside world you must do it via the web server. If you set environment
4620 variables like http_proxy or ftp_proxy to a values beginning with http://
4621 or in your web browser you have to set proxy information then you know
4622 you are running a http firewall.
4623
4624 To access servers outside these types of firewalls with perl (even for
4625 ftp) you will need to use LWP.
4626
4627 =item ftp firewall
4628
4629 This where the firewall machine runs a ftp server. This kind of firewall will
4630 only let you access ftp serves outside the firewall. This is usually done by
4631 connecting to the firewall with ftp, then entering a username like
4632 "user@outside.host.com"
4633
4634 To access servers outside these type of firewalls with perl you
4635 will need to use Net::FTP.
4636
4637 =item One way visibility
4638
4639 I say one way visibility as these firewalls try to make themselves look
4640 invisible to the users inside the firewall. An FTP data connection is
4641 normally created by sending the remote server your IP address and then
4642 listening for the connection. But the remote server will not be able to
4643 connect to you because of the firewall. So for these types of firewall
4644 FTP connections need to be done in a passive mode.
4645
4646 There are two that I can think off.
4647
4648 =over
4649
4650 =item SOCKS
4651
4652 If you are using a SOCKS firewall you will need to compile perl and link
4653 it with the SOCKS library, this is what is normally called a ``socksified''
4654 perl. With this executable you will be able to connect to servers outside
4655 the firewall as if it is not there.
4656
4657 =item IP Masquerade
4658
4659 This is the firewall implemented in the Linux kernel, it allows you to
4660 hide a complete network behind one IP address. With this firewall no
4661 special compiling is need as you can access hosts directly.
4662
4663 =back
4664
4665 =back
4666
4667 =head1 BUGS
4668
4669 We should give coverage for _all_ of the CPAN and not just the PAUSE
4670 part, right? In this discussion CPAN and PAUSE have become equal --
4671 but they are not. PAUSE is authors/ and modules/. CPAN is PAUSE plus
4672 the clpa/, doc/, misc/, ports/, src/, scripts/.
4673
4674 Future development should be directed towards a better integration of
4675 the other parts.
4676
4677 If a Makefile.PL requires special customization of libraries, prompts
4678 the user for special input, etc. then you may find CPAN is not able to
4679 build the distribution. In that case, you should attempt the
4680 traditional method of building a Perl module package from a shell.
4681
4682 =head1 AUTHOR
4683
4684 Andreas König E<lt>a.koenig@kulturbox.deE<gt>
4685
4686 =head1 SEE ALSO
4687
4688 perl(1), CPAN::Nox(3)
4689
4690 =cut
4691