lib/CPAN.pm

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