lib/CPAN.pm

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