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