lib/CPAN.pm

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