lib/CPAN.pm

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