lib/CPAN.pm

   1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
   2 package CPAN;
   3 $VERSION = '1.84';
   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 (); # $SelfLoader::DEBUG=1;
  17 use File::Basename ();
  18 use File::Copy ();
  19 use File::Find;
  20 use File::Path ();
  21 use File::Spec ();
  22 use FileHandle ();
  23 use Safe ();
  24 use Sys::Hostname qw(hostname);
  25 use Text::ParseWords ();
  26 use Text::Wrap ();
  27 no lib "."; # we need to run chdir all over and we would get at wrong
  28             # libraries there
  29
  30 require Mac::BuildTools if $^O eq 'MacOS';
  31
  32 END { $CPAN::End++; &cleanup; }
  33
  34 $CPAN::Signal ||= 0;
  35 $CPAN::Frontend ||= "CPAN::Shell";
  36 @CPAN::Defaultsites = ("http://www.perl.org/CPAN/","ftp://ftp.perl.org/pub/CPAN/")
  37     unless @CPAN::Defaultsites;
  38 # $CPAN::iCwd (i for initial) is going to be initialized during find_perl
  39 $CPAN::Perl ||= CPAN::find_perl();
  40 $CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?";
  41 $CPAN::Defaultrecent ||= "http://search.cpan.org/recent";
  42
  43
  44 package CPAN;
  45 use strict;
  46
  47 use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $HAS_USABLE $term
  48             $Signal $Suppress_readline $Frontend
  49             @Defaultsites $Have_warned $Defaultdocs $Defaultrecent
  50             $Be_Silent );
  51
  52 @CPAN::ISA = qw(CPAN::Debug Exporter);
  53
  54 # note that these functions live in CPAN::Shell and get executed via
  55 # AUTOLOAD when called directly
  56 @EXPORT = qw(
  57              autobundle
  58              bundle
  59              clean
  60              cvs_import
  61              expand
  62              force
  63              get
  64              install
  65              make
  66              mkmyconfig
  67              notest
  68              perldoc
  69              readme
  70              recent
  71              recompile
  72              shell
  73              test
  74             );
  75
  76 sub soft_chdir_with_alternatives ($);
  77
  78 #-> sub CPAN::AUTOLOAD ;
  79 sub AUTOLOAD {
  80     my($l) = $AUTOLOAD;
  81     $l =~ s/.*:://;
  82     my(%EXPORT);
  83     @EXPORT{@EXPORT} = '';
  84     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
  85     if (exists $EXPORT{$l}){
  86         CPAN::Shell->$l(@_);
  87     } else {
  88         $CPAN::Frontend->mywarn(qq{Unknown CPAN command "$AUTOLOAD". }.
  89                                 qq{Type ? for help.
  90 });
  91     }
  92 }
  93
  94 #-> sub CPAN::shell ;
  95 sub shell {
  96     my($self) = @_;
  97     $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
  98     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
  99
 100     my $oprompt = shift || CPAN::Prompt->new;
 101     my $prompt = $oprompt;
 102     my $commandline = shift || "";
 103     $CPAN::CurrentCommandId ||= 1;
 104
 105     local($^W) = 1;
 106     unless ($Suppress_readline) {
 107         require Term::ReadLine;
 108         if (! $term
 109             or
 110             $term->ReadLine eq "Term::ReadLine::Stub"
 111            ) {
 112             $term = Term::ReadLine->new('CPAN Monitor');
 113         }
 114         if ($term->ReadLine eq "Term::ReadLine::Gnu") {
 115             my $attribs = $term->Attribs;
 116              $attribs->{attempted_completion_function} = sub {
 117                  &CPAN::Complete::gnu_cpl;
 118              }
 119         } else {
 120             $readline::rl_completion_function =
 121                 $readline::rl_completion_function = 'CPAN::Complete::cpl';
 122         }
 123         if (my $histfile = $CPAN::Config->{'histfile'}) {{
 124             unless ($term->can("AddHistory")) {
 125                 $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
 126                 last;
 127             }
 128             my($fh) = FileHandle->new;
 129             open $fh, "<$histfile" or last;
 130             local $/ = "\n";
 131             while (<$fh>) {
 132                 chomp;
 133                 $term->AddHistory($_);
 134             }
 135             close $fh;
 136         }}
 137         # $term->OUT is autoflushed anyway
 138         my $odef = select STDERR;
 139         $| = 1;
 140         select STDOUT;
 141         $| = 1;
 142         select $odef;
 143     }
 144
 145     # no strict; # I do not recall why no strict was here (2000-09-03)
 146     $META->checklock();
 147     my @cwd = (
 148                CPAN::anycwd(),
 149                File::Spec->can("tmpdir") ? File::Spec->tmpdir() : (),
 150                File::Spec->rootdir(),
 151               );
 152     my $try_detect_readline;
 153     $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
 154     my $rl_avail = $Suppress_readline ? "suppressed" :
 155         ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
 156             "available (try 'install Bundle::CPAN')";
 157
 158     $CPAN::Frontend->myprint(
 159                              sprintf qq{
 160 cpan shell -- CPAN exploration and modules installation (v%s)
 161 ReadLine support %s
 162
 163 },
 164                              $CPAN::VERSION,
 165                              $rl_avail
 166                             )
 167         unless $CPAN::Config->{'inhibit_startup_message'} ;
 168     my($continuation) = "";
 169   SHELLCOMMAND: while () {
 170         if ($Suppress_readline) {
 171             print $prompt;
 172             last SHELLCOMMAND unless defined ($_ = <> );
 173             chomp;
 174         } else {
 175             last SHELLCOMMAND unless
 176                 defined ($_ = $term->readline($prompt, $commandline));
 177         }
 178         $_ = "$continuation$_" if $continuation;
 179         s/^\s+//;
 180         next SHELLCOMMAND if /^$/;
 181         $_ = 'h' if /^\s*\?/;
 182         if (/^(?:q(?:uit)?|bye|exit)$/i) {
 183             last SHELLCOMMAND;
 184         } elsif (s/\\$//s) {
 185             chomp;
 186             $continuation = $_;
 187             $prompt = "    > ";
 188         } elsif (/^\!/) {
 189             s/^\!//;
 190             my($eval) = $_;
 191             package CPAN::Eval;
 192             use strict;
 193             use vars qw($import_done);
 194             CPAN->import(':DEFAULT') unless $import_done++;
 195             CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
 196             eval($eval);
 197             warn $@ if $@;
 198             $continuation = "";
 199             $prompt = $oprompt;
 200         } elsif (/./) {
 201             my(@line);
 202             if ($] < 5.00322) { # parsewords had a bug until recently
 203                 @line = split;
 204             } else {
 205                 eval { @line = Text::ParseWords::shellwords($_) };
 206                 warn($@), next SHELLCOMMAND if $@;
 207                 warn("Text::Parsewords could not parse the line [$_]"),
 208                     next SHELLCOMMAND unless @line;
 209             }
 210             $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
 211             my $command = shift @line;
 212             eval { CPAN::Shell->$command(@line) };
 213             warn $@ if $@;
 214             if ($command =~ /^(make|test|install|force|notest)$/) {
 215                 CPAN::Shell->failed($CPAN::CurrentCommandId,1);
 216             }
 217             soft_chdir_with_alternatives(\@cwd);
 218             $CPAN::Frontend->myprint("\n");
 219             $continuation = "";
 220             $CPAN::CurrentCommandId++;
 221             $prompt = $oprompt;
 222         }
 223     } continue {
 224       $commandline = ""; # I do want to be able to pass a default to
 225                          # shell, but on the second command I see no
 226                          # use in that
 227       $Signal=0;
 228       CPAN::Queue->nullify_queue;
 229       if ($try_detect_readline) {
 230         if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
 231             ||
 232             $CPAN::META->has_inst("Term::ReadLine::Perl")
 233            ) {
 234             delete $INC{"Term/ReadLine.pm"};
 235             my $redef = 0;
 236             local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
 237             require Term::ReadLine;
 238             $CPAN::Frontend->myprint("\n$redef subroutines in ".
 239                                      "Term::ReadLine redefined\n");
 240             @_ = ($oprompt,"");
 241             goto &shell;
 242         }
 243       }
 244     }
 245     soft_chdir_with_alternatives(\@cwd);
 246 }
 247
 248 sub soft_chdir_with_alternatives ($) {
 249     my($cwd) = @_;
 250     while (not chdir $cwd->[0]) {
 251         if (@$cwd>1) {
 252             $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $!
 253 Trying to chdir to "$cwd->[1]" instead.
 254 });
 255             shift @$cwd;
 256         } else {
 257             $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!});
 258         }
 259     }
 260 }
 261
 262 package CPAN::CacheMgr;
 263 use strict;
 264 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
 265 use File::Find;
 266
 267 package CPAN::FTP;
 268 use strict;
 269 use vars qw($Ua $Thesite $ThesiteURL $Themethod);
 270 @CPAN::FTP::ISA = qw(CPAN::Debug);
 271
 272 package CPAN::LWP::UserAgent;
 273 use strict;
 274 use vars qw(@ISA $USER $PASSWD $SETUPDONE);
 275 # we delay requiring LWP::UserAgent and setting up inheritance until we need it
 276
 277 package CPAN::Complete;
 278 use strict;
 279 @CPAN::Complete::ISA = qw(CPAN::Debug);
 280 @CPAN::Complete::COMMANDS = sort qw(
 281                                     ! a b d h i m o q r u
 282                                     autobundle
 283                                     clean
 284                                     cvs_import
 285                                     dump
 286                                     force
 287                                     install
 288                                     look
 289                                     ls
 290                                     make
 291                                     mkmyconfig
 292                                     notest
 293                                     perldoc
 294                                     readme
 295                                     recent
 296                                     recompile
 297                                     reload
 298                                     test
 299 );
 300
 301 package CPAN::Index;
 302 use strict;
 303 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03);
 304 @CPAN::Index::ISA = qw(CPAN::Debug);
 305 $LAST_TIME ||= 0;
 306 $DATE_OF_03 ||= 0;
 307 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
 308 sub PROTOCOL { 2.0 }
 309
 310 package CPAN::InfoObj;
 311 use strict;
 312 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
 313
 314 package CPAN::Author;
 315 use strict;
 316 @CPAN::Author::ISA = qw(CPAN::InfoObj);
 317
 318 package CPAN::Distribution;
 319 use strict;
 320 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
 321
 322 package CPAN::Bundle;
 323 use strict;
 324 @CPAN::Bundle::ISA = qw(CPAN::Module);
 325
 326 package CPAN::Module;
 327 use strict;
 328 @CPAN::Module::ISA = qw(CPAN::InfoObj);
 329
 330 package CPAN::Exception::RecursiveDependency;
 331 use strict;
 332 use overload '""' => "as_string";
 333
 334 sub new {
 335     my($class) = shift;
 336     my($deps) = shift;
 337     my @deps;
 338     my %seen;
 339     for my $dep (@$deps) {
 340         push @deps, $dep;
 341         last if $seen{$dep}++;
 342     }
 343     bless { deps => \@deps }, $class;
 344 }
 345
 346 sub as_string {
 347     my($self) = shift;
 348     "\nRecursive dependency detected:\n    " .
 349         join("\n => ", @{$self->{deps}}) .
 350             ".\nCannot continue.\n";
 351 }
 352
 353 package CPAN::Prompt; use overload '""' => "as_string";
 354 use vars qw($prompt);
 355 $prompt = "cpan> ";
 356 $CPAN::CurrentCommandId ||= 0;
 357 sub as_randomly_capitalized_string {
 358     # pure fun variant
 359     substr($prompt,$_,1)=rand()<0.5 ?
 360         uc(substr($prompt,$_,1)) :
 361             lc(substr($prompt,$_,1)) for 0..3;
 362     $prompt;
 363 }
 364 sub new {
 365     bless {}, shift;
 366 }
 367 sub as_string {
 368     if ($CPAN::Config->{commandnumber_in_prompt}) {
 369         sprintf "cpan[%d]> ", $CPAN::CurrentCommandId;
 370     } else {
 371         "cpan> ";
 372     }
 373 }
 374
 375 package CPAN::Distrostatus;
 376 use overload '""' => "as_string",
 377     fallback => 1;
 378 sub new {
 379     my($class,$arg) = @_;
 380     bless {
 381            TEXT => $arg,
 382            FAILED => substr($arg,0,2) eq "NO",
 383            COMMANDID => $CPAN::CurrentCommandId,
 384           }, $class;
 385 }
 386 sub commandid { shift->{COMMANDID} }
 387 sub failed { shift->{FAILED} }
 388 sub text {
 389     my($self,$set) = @_;
 390     if (defined $set) {
 391         $self->{TEXT} = $set;
 392     }
 393     $self->{TEXT};
 394 }
 395 sub as_string {
 396     my($self) = @_;
 397     $self->text;
 398 }
 399
 400 package CPAN::Shell;
 401 use strict;
 402 use vars qw($AUTOLOAD @ISA $COLOR_REGISTERED $ADVANCED_QUERY $PRINT_ORNAMENTING);
 403 @CPAN::Shell::ISA = qw(CPAN::Debug);
 404 $COLOR_REGISTERED ||= 0;
 405 $PRINT_ORNAMENTING ||= 0;
 406
 407 #-> sub CPAN::Shell::AUTOLOAD ;
 408 sub AUTOLOAD {
 409     my($autoload) = $AUTOLOAD;
 410     my $class = shift(@_);
 411     # warn "autoload[$autoload] class[$class]";
 412     $autoload =~ s/.*:://;
 413     if ($autoload =~ /^w/) {
 414         if ($CPAN::META->has_inst('CPAN::WAIT')) {
 415             CPAN::WAIT->$autoload(@_);
 416         } else {
 417             $CPAN::Frontend->mywarn(qq{
 418 Commands starting with "w" require CPAN::WAIT to be installed.
 419 Please consider installing CPAN::WAIT to use the fulltext index.
 420 For this you just need to type
 421     install CPAN::WAIT
 422 });
 423         }
 424     } else {
 425         $CPAN::Frontend->mywarn(qq{Unknown shell command '$autoload'. }.
 426                                 qq{Type ? for help.
 427 });
 428     }
 429 }
 430
 431 package CPAN::Queue;
 432 use strict;
 433
 434 # One use of the queue is to determine if we should or shouldn't
 435 # announce the availability of a new CPAN module
 436
 437 # Now we try to use it for dependency tracking. For that to happen
 438 # we need to draw a dependency tree and do the leaves first. This can
 439 # easily be reached by running CPAN.pm recursively, but we don't want
 440 # to waste memory and run into deep recursion. So what we can do is
 441 # this:
 442
 443 # CPAN::Queue is the package where the queue is maintained. Dependencies
 444 # often have high priority and must be brought to the head of the queue,
 445 # possibly by jumping the queue if they are already there. My first code
 446 # attempt tried to be extremely correct. Whenever a module needed
 447 # immediate treatment, I either unshifted it to the front of the queue,
 448 # or, if it was already in the queue, I spliced and let it bypass the
 449 # others. This became a too correct model that made it impossible to put
 450 # an item more than once into the queue. Why would you need that? Well,
 451 # you need temporary duplicates as the manager of the queue is a loop
 452 # that
 453 #
 454 #  (1) looks at the first item in the queue without shifting it off
 455 #
 456 #  (2) cares for the item
 457 #
 458 #  (3) removes the item from the queue, *even if its agenda failed and
 459 #      even if the item isn't the first in the queue anymore* (that way
 460 #      protecting against never ending queues)
 461 #
 462 # So if an item has prerequisites, the installation fails now, but we
 463 # want to retry later. That's easy if we have it twice in the queue.
 464 #
 465 # I also expect insane dependency situations where an item gets more
 466 # than two lives in the queue. Simplest example is triggered by 'install
 467 # Foo Foo Foo'. People make this kind of mistakes and I don't want to
 468 # get in the way. I wanted the queue manager to be a dumb servant, not
 469 # one that knows everything.
 470 #
 471 # Who would I tell in this model that the user wants to be asked before
 472 # processing? I can't attach that information to the module object,
 473 # because not modules are installed but distributions. So I'd have to
 474 # tell the distribution object that it should ask the user before
 475 # processing. Where would the question be triggered then? Most probably
 476 # in CPAN::Distribution::rematein.
 477 # Hope that makes sense, my head is a bit off:-) -- AK
 478
 479 use vars qw{ @All };
 480
 481 # CPAN::Queue::new ;
 482 sub new {
 483   my($class,$s) = @_;
 484   my $self = bless { qmod => $s }, $class;
 485   push @All, $self;
 486   return $self;
 487 }
 488
 489 # CPAN::Queue::first ;
 490 sub first {
 491   my $obj = $All[0];
 492   $obj->{qmod};
 493 }
 494
 495 # CPAN::Queue::delete_first ;
 496 sub delete_first {
 497   my($class,$what) = @_;
 498   my $i;
 499   for my $i (0..$#All) {
 500     if (  $All[$i]->{qmod} eq $what ) {
 501       splice @All, $i, 1;
 502       return;
 503     }
 504   }
 505 }
 506
 507 # CPAN::Queue::jumpqueue ;
 508 sub jumpqueue {
 509     my $class = shift;
 510     my @what = @_;
 511     CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]",
 512                         join(",",map {$_->{qmod}} @All),
 513                         join(",",@what)
 514                        )) if $CPAN::DEBUG;
 515   WHAT: for my $what (reverse @what) {
 516         my $jumped = 0;
 517         for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
 518             CPAN->debug("i[$All[$i]]what[$what]") if $CPAN::DEBUG;
 519             if ($All[$i]->{qmod} eq $what){
 520                 $jumped++;
 521                 if ($jumped > 100) { # one's OK if e.g. just
 522                                      # processing now; more are OK if
 523                                      # user typed it several times
 524                     $CPAN::Frontend->mywarn(
 525 qq{Object [$what] queued more than 100 times, ignoring}
 526                                  );
 527                     next WHAT;
 528                 }
 529             }
 530         }
 531         my $obj = bless { qmod => $what }, $class;
 532         unshift @All, $obj;
 533     }
 534     CPAN->debug(sprintf("after jumpqueue All[%s] what[%s]",
 535                         join(",",map {$_->{qmod}} @All),
 536                         join(",",@what)
 537                        )) if $CPAN::DEBUG;
 538 }
 539
 540 # CPAN::Queue::exists ;
 541 sub exists {
 542   my($self,$what) = @_;
 543   my @all = map { $_->{qmod} } @All;
 544   my $exists = grep { $_->{qmod} eq $what } @All;
 545   # warn "in exists what[$what] all[@all] exists[$exists]";
 546   $exists;
 547 }
 548
 549 # CPAN::Queue::delete ;
 550 sub delete {
 551   my($self,$mod) = @_;
 552   @All = grep { $_->{qmod} ne $mod } @All;
 553 }
 554
 555 # CPAN::Queue::nullify_queue ;
 556 sub nullify_queue {
 557   @All = ();
 558 }
 559
 560
 561
 562 package CPAN;
 563 use strict;
 564
 565 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
 566
 567 # from here on only subs.
 568 ################################################################################
 569
 570 #-> sub CPAN::all_objects ;
 571 sub all_objects {
 572     my($mgr,$class) = @_;
 573     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 574     CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
 575     CPAN::Index->reload;
 576     values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
 577 }
 578 *all = \&all_objects;
 579
 580 # Called by shell, not in batch mode. In batch mode I see no risk in
 581 # having many processes updating something as installations are
 582 # continually checked at runtime. In shell mode I suspect it is
 583 # unintentional to open more than one shell at a time
 584
 585 #-> sub CPAN::checklock ;
 586 sub checklock {
 587     my($self) = @_;
 588     my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
 589     if (-f $lockfile && -M _ > 0) {
 590         my $fh = FileHandle->new($lockfile) or
 591             $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
 592         my $otherpid  = <$fh>;
 593         my $otherhost = <$fh>;
 594         $fh->close;
 595         if (defined $otherpid && $otherpid) {
 596             chomp $otherpid;
 597         }
 598         if (defined $otherhost && $otherhost) {
 599             chomp $otherhost;
 600         }
 601         my $thishost  = hostname();
 602         if (defined $otherhost && defined $thishost &&
 603             $otherhost ne '' && $thishost ne '' &&
 604             $otherhost ne $thishost) {
 605             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
 606                                            "reports other host $otherhost and other ".
 607                                            "process $otherpid.\n".
 608                                            "Cannot proceed.\n"));
 609         }
 610         elsif (defined $otherpid && $otherpid) {
 611             return if $$ == $otherpid; # should never happen
 612             $CPAN::Frontend->mywarn(
 613                                     qq{
 614 There seems to be running another CPAN process (pid $otherpid).  Contacting...
 615 });
 616             if (kill 0, $otherpid) {
 617                 $CPAN::Frontend->mydie(qq{Other job is running.
 618 You may want to kill it and delete the lockfile, maybe. On UNIX try:
 619     kill $otherpid
 620     rm $lockfile
 621 });
 622             } elsif (-w $lockfile) {
 623                 my($ans) =
 624                     ExtUtils::MakeMaker::prompt
 625                         (qq{Other job not responding. Shall I overwrite }.
 626                          qq{the lockfile '$lockfile'? (Y/n)},"y");
 627                 $CPAN::Frontend->myexit("Ok, bye\n")
 628                     unless $ans =~ /^y/i;
 629             } else {
 630                 Carp::croak(
 631                             qq{Lockfile '$lockfile' not writeable by you. }.
 632                             qq{Cannot proceed.\n}.
 633                             qq{    On UNIX try:\n}.
 634                             qq{    rm '$lockfile'\n}.
 635                             qq{  and then rerun us.\n}
 636                            );
 637             }
 638         } else {
 639             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
 640                                            "reports other process with ID ".
 641                                            "$otherpid. Cannot proceed.\n"));
 642         }
 643     }
 644     my $dotcpan = $CPAN::Config->{cpan_home};
 645     eval { File::Path::mkpath($dotcpan);};
 646     if ($@) {
 647       # A special case at least for Jarkko.
 648       my $firsterror = $@;
 649       my $seconderror;
 650       my $symlinkcpan;
 651       if (-l $dotcpan) {
 652         $symlinkcpan = readlink $dotcpan;
 653         die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
 654         eval { File::Path::mkpath($symlinkcpan); };
 655         if ($@) {
 656           $seconderror = $@;
 657         } else {
 658           $CPAN::Frontend->mywarn(qq{
 659 Working directory $symlinkcpan created.
 660 });
 661         }
 662       }
 663       unless (-d $dotcpan) {
 664         my $diemess = qq{
 665 Your configuration suggests "$dotcpan" as your
 666 CPAN.pm working directory. I could not create this directory due
 667 to this error: $firsterror\n};
 668         $diemess .= qq{
 669 As "$dotcpan" is a symlink to "$symlinkcpan",
 670 I tried to create that, but I failed with this error: $seconderror
 671 } if $seconderror;
 672         $diemess .= qq{
 673 Please make sure the directory exists and is writable.
 674 };
 675         $CPAN::Frontend->mydie($diemess);
 676       }
 677     } # $@ after eval mkpath $dotcpan
 678     my $fh;
 679     unless ($fh = FileHandle->new(">$lockfile")) {
 680         if ($! =~ /Permission/) {
 681             my $incc = $INC{'CPAN/Config.pm'};
 682             my $myincc = File::Spec->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm');
 683             $CPAN::Frontend->myprint(qq{
 684
 685 Your configuration suggests that CPAN.pm should use a working
 686 directory of
 687     $CPAN::Config->{cpan_home}
 688 Unfortunately we could not create the lock file
 689     $lockfile
 690 due to permission problems.
 691
 692 Please make sure that the configuration variable
 693     \$CPAN::Config->{cpan_home}
 694 points to a directory where you can write a .lock file. You can set
 695 this variable in either
 696     $incc
 697 or
 698     $myincc
 699 });
 700             if(!$INC{'CPAN/MyConfig.pm'}) {
 701                 $CPAN::Frontend->myprint("You don't seem to have a user ".
 702                                          "configuration (MyConfig.pm) yet.\n");
 703                 my $new = ExtUtils::MakeMaker::prompt("Do you want to create a ".
 704                                                       "user configuration now? (Y/n)",
 705                                                       "yes");
 706                 if($new =~ m{^y}i) {
 707                     CPAN::Shell->mkmyconfig();
 708                     return &checklock;
 709                 }
 710             }
 711         }
 712         $CPAN::Frontend->mydie("Could not open >$lockfile: $!");
 713     }
 714     $fh->print($$, "\n");
 715     $fh->print(hostname(), "\n");
 716     $self->{LOCK} = $lockfile;
 717     $fh->close;
 718     $SIG{TERM} = sub {
 719       &cleanup;
 720       $CPAN::Frontend->mydie("Got SIGTERM, leaving");
 721     };
 722     $SIG{INT} = sub {
 723       # no blocks!!!
 724       &cleanup if $Signal;
 725       $CPAN::Frontend->mydie("Got another SIGINT") if $Signal;
 726       print "Caught SIGINT\n";
 727       $Signal++;
 728     };
 729
 730 #       From: Larry Wall <larry@wall.org>
 731 #       Subject: Re: deprecating SIGDIE
 732 #       To: perl5-porters@perl.org
 733 #       Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
 734 #
 735 #       The original intent of __DIE__ was only to allow you to substitute one
 736 #       kind of death for another on an application-wide basis without respect
 737 #       to whether you were in an eval or not.  As a global backstop, it should
 738 #       not be used any more lightly (or any more heavily :-) than class
 739 #       UNIVERSAL.  Any attempt to build a general exception model on it should
 740 #       be politely squashed.  Any bug that causes every eval {} to have to be
 741 #       modified should be not so politely squashed.
 742 #
 743 #       Those are my current opinions.  It is also my optinion that polite
 744 #       arguments degenerate to personal arguments far too frequently, and that
 745 #       when they do, it's because both people wanted it to, or at least didn't
 746 #       sufficiently want it not to.
 747 #
 748 #       Larry
 749
 750     # global backstop to cleanup if we should really die
 751     $SIG{__DIE__} = \&cleanup;
 752     $self->debug("Signal handler set.") if $CPAN::DEBUG;
 753 }
 754
 755 #-> sub CPAN::DESTROY ;
 756 sub DESTROY {
 757     &cleanup; # need an eval?
 758 }
 759
 760 #-> sub CPAN::anycwd ;
 761 sub anycwd () {
 762     my $getcwd;
 763     $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
 764     CPAN->$getcwd();
 765 }
 766
 767 #-> sub CPAN::cwd ;
 768 sub cwd {Cwd::cwd();}
 769
 770 #-> sub CPAN::getcwd ;
 771 sub getcwd {Cwd::getcwd();}
 772
 773 #-> sub CPAN::fastcwd ;
 774 sub fastcwd {Cwd::fastcwd();}
 775
 776 #-> sub CPAN::backtickcwd ;
 777 sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
 778
 779 #-> sub CPAN::find_perl ;
 780 sub find_perl {
 781     my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
 782     my $pwd  = $CPAN::iCwd = CPAN::anycwd();
 783     my $candidate = File::Spec->catfile($pwd,$^X);
 784     $perl ||= $candidate if MM->maybe_command($candidate);
 785
 786     unless ($perl) {
 787         my ($component,$perl_name);
 788       DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
 789             PATH_COMPONENT: foreach $component (File::Spec->path(),
 790                                                 $Config::Config{'binexp'}) {
 791                   next unless defined($component) && $component;
 792                   my($abs) = File::Spec->catfile($component,$perl_name);
 793                   if (MM->maybe_command($abs)) {
 794                       $perl = $abs;
 795                       last DIST_PERLNAME;
 796                   }
 797               }
 798           }
 799     }
 800
 801     return $perl;
 802 }
 803
 804
 805 #-> sub CPAN::exists ;
 806 sub exists {
 807     my($mgr,$class,$id) = @_;
 808     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 809     CPAN::Index->reload;
 810     ### Carp::croak "exists called without class argument" unless $class;
 811     $id ||= "";
 812     $id =~ s/:+/::/g if $class eq "CPAN::Module";
 813     exists $META->{readonly}{$class}{$id} or
 814         exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
 815 }
 816
 817 #-> sub CPAN::delete ;
 818 sub delete {
 819   my($mgr,$class,$id) = @_;
 820   delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
 821   delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
 822 }
 823
 824 #-> sub CPAN::has_usable
 825 # has_inst is sometimes too optimistic, we should replace it with this
 826 # has_usable whenever a case is given
 827 sub has_usable {
 828     my($self,$mod,$message) = @_;
 829     return 1 if $HAS_USABLE->{$mod};
 830     my $has_inst = $self->has_inst($mod,$message);
 831     return unless $has_inst;
 832     my $usable;
 833     $usable = {
 834                LWP => [ # we frequently had "Can't locate object
 835                         # method "new" via package "LWP::UserAgent" at
 836                         # (eval 69) line 2006
 837                        sub {require LWP},
 838                        sub {require LWP::UserAgent},
 839                        sub {require HTTP::Request},
 840                        sub {require URI::URL},
 841                       ],
 842                'Net::FTP' => [
 843                             sub {require Net::FTP},
 844                             sub {require Net::Config},
 845                            ]
 846               };
 847     if ($usable->{$mod}) {
 848       for my $c (0..$#{$usable->{$mod}}) {
 849         my $code = $usable->{$mod}[$c];
 850         my $ret = eval { &$code() };
 851         if ($@) {
 852           warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
 853           return;
 854         }
 855       }
 856     }
 857     return $HAS_USABLE->{$mod} = 1;
 858 }
 859
 860 #-> sub CPAN::has_inst
 861 sub has_inst {
 862     my($self,$mod,$message) = @_;
 863     Carp::croak("CPAN->has_inst() called without an argument")
 864         unless defined $mod;
 865     my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
 866         keys %{$CPAN::Config->{dontload_hash}||{}},
 867             @{$CPAN::Config->{dontload_list}||[]};
 868     if (defined $message && $message eq "no"  # afair only used by Nox
 869         ||
 870         $dont{$mod}
 871        ) {
 872       $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
 873       return 0;
 874     }
 875     my $file = $mod;
 876     my $obj;
 877     $file =~ s|::|/|g;
 878     $file .= ".pm";
 879     if ($INC{$file}) {
 880         # checking %INC is wrong, because $INC{LWP} may be true
 881         # although $INC{"URI/URL.pm"} may have failed. But as
 882         # I really want to say "bla loaded OK", I have to somehow
 883         # cache results.
 884         ### warn "$file in %INC"; #debug
 885         return 1;
 886     } elsif (eval { require $file }) {
 887         # eval is good: if we haven't yet read the database it's
 888         # perfect and if we have installed the module in the meantime,
 889         # it tries again. The second require is only a NOOP returning
 890         # 1 if we had success, otherwise it's retrying
 891
 892         $CPAN::Frontend->myprint("CPAN: $mod loaded ok\n");
 893         if ($mod eq "CPAN::WAIT") {
 894             push @CPAN::Shell::ISA, 'CPAN::WAIT';
 895         }
 896         return 1;
 897     } elsif ($mod eq "Net::FTP") {
 898         $CPAN::Frontend->mywarn(qq{
 899   Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
 900   if you just type
 901       install Bundle::libnet
 902
 903 }) unless $Have_warned->{"Net::FTP"}++;
 904         sleep 3;
 905     } elsif ($mod eq "Digest::SHA"){
 906         if ($Have_warned->{"Digest::SHA"}++) {
 907             $CPAN::Frontend->myprint(qq{CPAN: checksum security checks disabled}.
 908                                      qq{because Digest::SHA not installed.\n});
 909         } else {
 910             $CPAN::Frontend->myprint(qq{
 911   CPAN: checksum security checks disabled because Digest::SHA not installed.
 912   Please consider installing the Digest::SHA module.
 913
 914 });
 915             sleep 2;
 916         }
 917     } elsif ($mod eq "Module::Signature"){
 918         unless ($Have_warned->{"Module::Signature"}++) {
 919             # No point in complaining unless the user can
 920             # reasonably install and use it.
 921             if (eval { require Crypt::OpenPGP; 1 } ||
 922                 defined $CPAN::Config->{'gpg'}) {
 923                 $CPAN::Frontend->myprint(qq{
 924   CPAN: Module::Signature security checks disabled because Module::Signature
 925   not installed.  Please consider installing the Module::Signature module.
 926   You may also need to be able to connect over the Internet to the public
 927   keyservers like pgp.mit.edu (port 11371).
 928
 929 });
 930                 sleep 2;
 931             }
 932         }
 933     } else {
 934         delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
 935     }
 936     return 0;
 937 }
 938
 939 #-> sub CPAN::instance ;
 940 sub instance {
 941     my($mgr,$class,$id) = @_;
 942     CPAN::Index->reload;
 943     $id ||= "";
 944     # unsafe meta access, ok?
 945     return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
 946     $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
 947 }
 948
 949 #-> sub CPAN::new ;
 950 sub new {
 951     bless {}, shift;
 952 }
 953
 954 #-> sub CPAN::cleanup ;
 955 sub cleanup {
 956   # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
 957   local $SIG{__DIE__} = '';
 958   my($message) = @_;
 959   my $i = 0;
 960   my $ineval = 0;
 961   my($subroutine);
 962   while ((undef,undef,undef,$subroutine) = caller(++$i)) {
 963       $ineval = 1, last if
 964           $subroutine eq '(eval)';
 965   }
 966   return if $ineval && !$CPAN::End;
 967   return unless defined $META->{LOCK};
 968   return unless -f $META->{LOCK};
 969   $META->savehist;
 970   unlink $META->{LOCK};
 971   # require Carp;
 972   # Carp::cluck("DEBUGGING");
 973   $CPAN::Frontend->mywarn("Lockfile removed.\n");
 974 }
 975
 976 #-> sub CPAN::savehist
 977 sub savehist {
 978     my($self) = @_;
 979     my($histfile,$histsize);
 980     unless ($histfile = $CPAN::Config->{'histfile'}){
 981         $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
 982         return;
 983     }
 984     $histsize = $CPAN::Config->{'histsize'} || 100;
 985     if ($CPAN::term){
 986         unless ($CPAN::term->can("GetHistory")) {
 987             $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
 988             return;
 989         }
 990     } else {
 991         return;
 992     }
 993     my @h = $CPAN::term->GetHistory;
 994     splice @h, 0, @h-$histsize if @h>$histsize;
 995     my($fh) = FileHandle->new;
 996     open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
 997     local $\ = local $, = "\n";
 998     print $fh @h;
 999     close $fh;
1000 }
1001
1002 sub is_tested {
1003     my($self,$what) = @_;
1004     $self->{is_tested}{$what} = 1;
1005 }
1006
1007 sub is_installed {
1008     my($self,$what) = @_;
1009     delete $self->{is_tested}{$what};
1010 }
1011
1012 sub set_perl5lib {
1013     my($self) = @_;
1014     $self->{is_tested} ||= {};
1015     return unless %{$self->{is_tested}};
1016     my $env = $ENV{PERL5LIB};
1017     $env = $ENV{PERLLIB} unless defined $env;
1018     my @env;
1019     push @env, $env if defined $env and length $env;
1020     my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
1021     $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
1022     $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1023 }
1024
1025 package CPAN::CacheMgr;
1026 use strict;
1027
1028 #-> sub CPAN::CacheMgr::as_string ;
1029 sub as_string {
1030     eval { require Data::Dumper };
1031     if ($@) {
1032         return shift->SUPER::as_string;
1033     } else {
1034         return Data::Dumper::Dumper(shift);
1035     }
1036 }
1037
1038 #-> sub CPAN::CacheMgr::cachesize ;
1039 sub cachesize {
1040     shift->{DU};
1041 }
1042
1043 #-> sub CPAN::CacheMgr::tidyup ;
1044 sub tidyup {
1045   my($self) = @_;
1046   return unless -d $self->{ID};
1047   while ($self->{DU} > $self->{'MAX'} ) {
1048     my($toremove) = shift @{$self->{FIFO}};
1049     $CPAN::Frontend->myprint(sprintf(
1050                                      "Deleting from cache".
1051                                      ": $toremove (%.1f>%.1f MB)\n",
1052                                      $self->{DU}, $self->{'MAX'})
1053                             );
1054     return if $CPAN::Signal;
1055     $self->force_clean_cache($toremove);
1056     return if $CPAN::Signal;
1057   }
1058 }
1059
1060 #-> sub CPAN::CacheMgr::dir ;
1061 sub dir {
1062     shift->{ID};
1063 }
1064
1065 #-> sub CPAN::CacheMgr::entries ;
1066 sub entries {
1067     my($self,$dir) = @_;
1068     return unless defined $dir;
1069     $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
1070     $dir ||= $self->{ID};
1071     my($cwd) = CPAN::anycwd();
1072     chdir $dir or Carp::croak("Can't chdir to $dir: $!");
1073     my $dh = DirHandle->new(File::Spec->curdir)
1074         or Carp::croak("Couldn't opendir $dir: $!");
1075     my(@entries);
1076     for ($dh->read) {
1077         next if $_ eq "." || $_ eq "..";
1078         if (-f $_) {
1079             push @entries, File::Spec->catfile($dir,$_);
1080         } elsif (-d _) {
1081             push @entries, File::Spec->catdir($dir,$_);
1082         } else {
1083             $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
1084         }
1085     }
1086     chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
1087     sort { -M $b <=> -M $a} @entries;
1088 }
1089
1090 #-> sub CPAN::CacheMgr::disk_usage ;
1091 sub disk_usage {
1092     my($self,$dir) = @_;
1093     return if exists $self->{SIZE}{$dir};
1094     return if $CPAN::Signal;
1095     my($Du) = 0;
1096     if (-e $dir) {
1097         unless (-x $dir) {
1098             unless (chmod 0755, $dir) {
1099                 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
1100                                         "permission to change the permission; cannot ".
1101                                         "estimate disk usage of '$dir'\n");
1102                 $CPAN::Frontend->mysleep(5);
1103                 return;
1104             }
1105         }
1106     } else {
1107         $CPAN::Frontend->mywarn("Directory '$dir' has gone. Cannot continue.\n");
1108         $CPAN::Frontend->mysleep(2);
1109         return;
1110     }
1111     find(
1112          sub {
1113            $File::Find::prune++ if $CPAN::Signal;
1114            return if -l $_;
1115            if ($^O eq 'MacOS') {
1116              require Mac::Files;
1117              my $cat  = Mac::Files::FSpGetCatInfo($_);
1118              $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
1119            } else {
1120              if (-d _) {
1121                unless (-x _) {
1122                  unless (chmod 0755, $_) {
1123                    $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
1124                                            "the permission to change the permission; ".
1125                                            "can only partially estimate disk usage ".
1126                                            "of '$_'\n");
1127                    sleep 5;
1128                    return;
1129                  }
1130                }
1131              } else {
1132                $Du += (-s _);
1133              }
1134            }
1135          },
1136          $dir
1137         );
1138     return if $CPAN::Signal;
1139     $self->{SIZE}{$dir} = $Du/1024/1024;
1140     push @{$self->{FIFO}}, $dir;
1141     $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
1142     $self->{DU} += $Du/1024/1024;
1143     $self->{DU};
1144 }
1145
1146 #-> sub CPAN::CacheMgr::force_clean_cache ;
1147 sub force_clean_cache {
1148     my($self,$dir) = @_;
1149     return unless -e $dir;
1150     $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
1151         if $CPAN::DEBUG;
1152     File::Path::rmtree($dir);
1153     $self->{DU} -= $self->{SIZE}{$dir};
1154     delete $self->{SIZE}{$dir};
1155 }
1156
1157 #-> sub CPAN::CacheMgr::new ;
1158 sub new {
1159     my $class = shift;
1160     my $time = time;
1161     my($debug,$t2);
1162     $debug = "";
1163     my $self = {
1164                 ID => $CPAN::Config->{'build_dir'},
1165                 MAX => $CPAN::Config->{'build_cache'},
1166                 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
1167                 DU => 0
1168                };
1169     File::Path::mkpath($self->{ID});
1170     my $dh = DirHandle->new($self->{ID});
1171     bless $self, $class;
1172     $self->scan_cache;
1173     $t2 = time;
1174     $debug .= "timing of CacheMgr->new: ".($t2 - $time);
1175     $time = $t2;
1176     CPAN->debug($debug) if $CPAN::DEBUG;
1177     $self;
1178 }
1179
1180 #-> sub CPAN::CacheMgr::scan_cache ;
1181 sub scan_cache {
1182     my $self = shift;
1183     return if $self->{SCAN} eq 'never';
1184     $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
1185         unless $self->{SCAN} eq 'atstart';
1186     $CPAN::Frontend->myprint(
1187                              sprintf("Scanning cache %s for sizes\n",
1188                                      $self->{ID}));
1189     my $e;
1190     for $e ($self->entries($self->{ID})) {
1191         next if $e eq ".." || $e eq ".";
1192         $self->disk_usage($e);
1193         return if $CPAN::Signal;
1194     }
1195     $self->tidyup;
1196 }
1197
1198 package CPAN::Shell;
1199 use strict;
1200
1201 #-> sub CPAN::Shell::h ;
1202 sub h {
1203     my($class,$about) = @_;
1204     if (defined $about) {
1205         $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1206     } else {
1207         my $filler = " " x (80 - 28 - length($CPAN::VERSION));
1208         $CPAN::Frontend->myprint(qq{
1209 Display Information $filler (ver $CPAN::VERSION)
1210  command  argument          description
1211  a,b,d,m  WORD or /REGEXP/  about authors, bundles, distributions, modules
1212  i        WORD or /REGEXP/  about any of the above
1213  r        NONE              report updatable modules
1214  ls       AUTHOR or GLOB    about files in the author's directory
1215     (with WORD being a module, bundle or author name or a distribution
1216     name of the form AUTHOR/DISTRIBUTION)
1217
1218 Download, Test, Make, Install...
1219  get      download                     clean    make clean
1220  make     make (implies get)           look     open subshell in dist directory
1221  test     make test (implies make)     readme   display these README files
1222  install  make install (implies test)  perldoc  display POD documentation
1223
1224 Pragmas
1225  force COMMAND    unconditionally do command
1226  notest COMMAND   skip testing
1227
1228 Other
1229  h,?           display this menu       ! perl-code   eval a perl command
1230  o conf [opt]  set and query options   q             quit the cpan shell
1231  reload cpan   load CPAN.pm again      reload index  load newer indices
1232  autobundle    Snapshot                recent        latest CPAN uploads});
1233     }
1234 }
1235
1236 *help = \&h;
1237
1238 #-> sub CPAN::Shell::a ;
1239 sub a {
1240   my($self,@arg) = @_;
1241   # authors are always UPPERCASE
1242   for (@arg) {
1243     $_ = uc $_ unless /=/;
1244   }
1245   $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1246 }
1247
1248 #-> sub CPAN::Shell::globls ;
1249 sub globls {
1250     my($self,$s,$pragmas) = @_;
1251     # ls is really very different, but we had it once as an ordinary
1252     # command in the Shell (upto rev. 321) and we could not handle
1253     # force well then
1254     my(@accept,@preexpand);
1255     if ($s =~ /[\*\?\/]/) {
1256         if ($CPAN::META->has_inst("Text::Glob")) {
1257             if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
1258                 my $rau = Text::Glob::glob_to_regex(uc $au);
1259                 CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
1260                       if $CPAN::DEBUG;
1261                 push @preexpand, map { $_->id . "/" . $pathglob }
1262                     CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
1263             } else {
1264                 my $rau = Text::Glob::glob_to_regex(uc $s);
1265                 push @preexpand, map { $_->id }
1266                     CPAN::Shell->expand_by_method('CPAN::Author',
1267                                                   ['id'],
1268                                                   "/$rau/");
1269             }
1270         } else {
1271             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
1272         }
1273     } else {
1274         push @preexpand, uc $s;
1275     }
1276     for (@preexpand) {
1277         unless (/^[A-Z0-9\-]+(\/|$)/i) {
1278             $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
1279             next;
1280         }
1281         push @accept, $_;
1282     }
1283     my $silent = @accept>1;
1284     my $last_alpha = "";
1285     my @results;
1286     for my $a (@accept){
1287         my($author,$pathglob);
1288         if ($a =~ m|(.*?)/(.*)|) {
1289             my $a2 = $1;
1290             $pathglob = $2;
1291             $author = CPAN::Shell->expand_by_method('CPAN::Author',
1292                                                     ['id'],
1293                                                     $a2) or die "No author found for $a2";
1294         } else {
1295             $author = CPAN::Shell->expand_by_method('CPAN::Author',
1296                                                     ['id'],
1297                                                     $a) or die "No author found for $a";
1298         }
1299         if ($silent) {
1300             my $alpha = substr $author->id, 0, 1;
1301             my $ad;
1302             if ($alpha eq $last_alpha) {
1303                 $ad = "";
1304             } else {
1305                 $ad = "[$alpha]";
1306                 $last_alpha = $alpha;
1307             }
1308             $CPAN::Frontend->myprint($ad);
1309         }
1310         for my $pragma (@$pragmas) {
1311             if ($author->can($pragma)) {
1312                 $author->$pragma();
1313             }
1314         }
1315         push @results, $author->ls($pathglob,$silent); # silent if
1316                                                        # more than one
1317                                                        # author
1318         for my $pragma (@$pragmas) {
1319             my $meth = "un$pragma";
1320             if ($author->can($meth)) {
1321                 $author->$meth();
1322             }
1323         }
1324     }
1325     @results;
1326 }
1327
1328 #-> sub CPAN::Shell::local_bundles ;
1329 sub local_bundles {
1330     my($self,@which) = @_;
1331     my($incdir,$bdir,$dh);
1332     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1333         my @bbase = "Bundle";
1334         while (my $bbase = shift @bbase) {
1335             $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
1336             CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1337             if ($dh = DirHandle->new($bdir)) { # may fail
1338                 my($entry);
1339                 for $entry ($dh->read) {
1340                     next if $entry =~ /^\./;
1341                     if (-d File::Spec->catdir($bdir,$entry)){
1342                         push @bbase, "$bbase\::$entry";
1343                     } else {
1344                         next unless $entry =~ s/\.pm(?!\n)\Z//;
1345                         $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1346                     }
1347                 }
1348             }
1349         }
1350     }
1351 }
1352
1353 #-> sub CPAN::Shell::b ;
1354 sub b {
1355     my($self,@which) = @_;
1356     CPAN->debug("which[@which]") if $CPAN::DEBUG;
1357     $self->local_bundles;
1358     $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1359 }
1360
1361 #-> sub CPAN::Shell::d ;
1362 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1363
1364 #-> sub CPAN::Shell::m ;
1365 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1366     my $self = shift;
1367     $CPAN::Frontend->myprint($self->format_result('Module',@_));
1368 }
1369
1370 #-> sub CPAN::Shell::i ;
1371 sub i {
1372     my($self) = shift;
1373     my(@args) = @_;
1374     @args = '/./' unless @args;
1375     my(@result);
1376     for my $type (qw/Bundle Distribution Module/) {
1377         push @result, $self->expand($type,@args);
1378     }
1379     # Authors are always uppercase.
1380     push @result, $self->expand("Author", map { uc $_ } @args);
1381
1382     my $result = @result == 1 ?
1383         $result[0]->as_string :
1384             @result == 0 ?
1385                 "No objects found of any type for argument @args\n" :
1386                     join("",
1387                          (map {$_->as_glimpse} @result),
1388                          scalar @result, " items found\n",
1389                         );
1390     $CPAN::Frontend->myprint($result);
1391 }
1392
1393 #-> sub CPAN::Shell::o ;
1394
1395 # CPAN::Shell::o and CPAN::Config::edit are closely related. 'o conf'
1396 # should have been called set and 'o debug' maybe 'set debug'
1397 sub o {
1398     my($self,$o_type,@o_what) = @_;
1399     $DB::single = 1;
1400     $o_type ||= "";
1401     CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1402     if ($o_type eq 'conf') {
1403         if (!@o_what) { # print all things, "o conf"
1404             my($k,$v);
1405             $CPAN::Frontend->myprint("CPAN::Config options");
1406             if (exists $INC{'CPAN/Config.pm'}) {
1407               $CPAN::Frontend->myprint(" from $INC{'CPAN/Config.pm'}");
1408             }
1409             if (exists $INC{'CPAN/MyConfig.pm'}) {
1410               $CPAN::Frontend->myprint(" and $INC{'CPAN/MyConfig.pm'}");
1411             }
1412             $CPAN::Frontend->myprint(":\n");
1413             for $k (sort keys %CPAN::HandleConfig::can) {
1414                 $v = $CPAN::HandleConfig::can{$k};
1415                 $CPAN::Frontend->myprint(sprintf "    %-18s [%s]\n", $k, $v);
1416             }
1417             $CPAN::Frontend->myprint("\n");
1418             for $k (sort keys %$CPAN::Config) {
1419                 CPAN::HandleConfig->prettyprint($k);
1420             }
1421             $CPAN::Frontend->myprint("\n");
1422         } elsif (!CPAN::HandleConfig->edit(@o_what)) {
1423             $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
1424                                      qq{items\n\n});
1425         }
1426     } elsif ($o_type eq 'debug') {
1427         my(%valid);
1428         @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1429         if (@o_what) {
1430             while (@o_what) {
1431                 my($what) = shift @o_what;
1432                 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
1433                     $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
1434                     next;
1435                 }
1436                 if ( exists $CPAN::DEBUG{$what} ) {
1437                     $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1438                 } elsif ($what =~ /^\d/) {
1439                     $CPAN::DEBUG = $what;
1440                 } elsif (lc $what eq 'all') {
1441                     my($max) = 0;
1442                     for (values %CPAN::DEBUG) {
1443                         $max += $_;
1444                     }
1445                     $CPAN::DEBUG = $max;
1446                 } else {
1447                     my($known) = 0;
1448                     for (keys %CPAN::DEBUG) {
1449                         next unless lc($_) eq lc($what);
1450                         $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1451                         $known = 1;
1452                     }
1453                     $CPAN::Frontend->myprint("unknown argument [$what]\n")
1454                         unless $known;
1455                 }
1456             }
1457         } else {
1458           my $raw = "Valid options for debug are ".
1459               join(", ",sort(keys %CPAN::DEBUG), 'all').
1460                   qq{ or a number. Completion works on the options. }.
1461                       qq{Case is ignored.};
1462           require Text::Wrap;
1463           $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1464           $CPAN::Frontend->myprint("\n\n");
1465         }
1466         if ($CPAN::DEBUG) {
1467             $CPAN::Frontend->myprint("Options set for debugging:\n");
1468             my($k,$v);
1469             for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1470                 $v = $CPAN::DEBUG{$k};
1471                 $CPAN::Frontend->myprint(sprintf "    %-14s(%s)\n", $k, $v)
1472                     if $v & $CPAN::DEBUG;
1473             }
1474         } else {
1475             $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1476         }
1477     } else {
1478         $CPAN::Frontend->myprint(qq{
1479 Known options:
1480   conf    set or get configuration variables
1481   debug   set or get debugging options
1482 });
1483     }
1484 }
1485
1486 sub paintdots_onreload {
1487     my($ref) = shift;
1488     sub {
1489         if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
1490             my($subr) = $1;
1491             ++$$ref;
1492             local($|) = 1;
1493             # $CPAN::Frontend->myprint(".($subr)");
1494             $CPAN::Frontend->myprint(".");
1495             return;
1496         }
1497         warn @_;
1498     };
1499 }
1500
1501 #-> sub CPAN::Shell::reload ;
1502 sub reload {
1503     my($self,$command,@arg) = @_;
1504     $command ||= "";
1505     $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1506     if ($command =~ /cpan/i) {
1507         my $redef = 0;
1508         chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
1509         my $failed;
1510       MFILE: for my $f (qw(CPAN.pm CPAN/HandleConfig.pm CPAN/FirstTime.pm CPAN/Tarzip.pm
1511                       CPAN/Debug.pm CPAN/Version.pm)) {
1512             local($SIG{__WARN__}) = paintdots_onreload(\$redef);
1513             $self->reload_this($f) or $failed++;
1514         }
1515         $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1516         $failed++ unless $redef;
1517         if ($failed) {
1518             $CPAN::Frontend->mywarn("\n$failed errors during reload. You better quit ".
1519                                     "this session.\n");
1520         }
1521     } elsif ($command =~ /index/) {
1522       CPAN::Index->force_reload;
1523     } else {
1524       $CPAN::Frontend->myprint(qq{cpan     re-evals the CPAN.pm file
1525 index    re-reads the index files\n});
1526     }
1527 }
1528
1529 sub reload_this {
1530     my($self,$f) = @_;
1531     return 1 unless $INC{$f};
1532     my $pwd = CPAN::anycwd();
1533     CPAN->debug("reloading the whole '$f' from '$INC{$f}' while pwd='$pwd'")
1534         if $CPAN::DEBUG;
1535     my $read;
1536     for my $inc (@INC) {
1537         $read = File::Spec->catfile($inc,split /\//, $f);
1538         last if -f $read;
1539     }
1540     unless (-f $read) {
1541         $read = $INC{$f};
1542     }
1543     unless (-f $read) {
1544         $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
1545         return;
1546     }
1547     my $fh = FileHandle->new($read) or
1548         $CPAN::Frontend->mydie("Could not open $read: $!");
1549     local($/);
1550     local $^W = 1;
1551     my $eval = <$fh>;
1552     CPAN->debug(sprintf("evaling [%s...]\n",substr($eval,0,64)))
1553         if $CPAN::DEBUG;
1554     eval $eval;
1555     if ($@){
1556         warn $@;
1557         return;
1558     }
1559     return 1;
1560 }
1561
1562 #-> sub CPAN::Shell::mkmyconfig ;
1563 sub mkmyconfig {
1564     my($self, $cpanpm, %args) = @_;
1565     require CPAN::FirstTime;
1566     $cpanpm = $INC{'CPAN/MyConfig.pm'} || "$ENV{HOME}/.cpan/CPAN/MyConfig.pm";
1567     File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm;
1568     if(!$INC{'CPAN/Config.pm'}) {
1569         eval { require CPAN::Config; };
1570     }
1571     $CPAN::Config ||= {};
1572     $CPAN::Config = {
1573         %$CPAN::Config,
1574         build_dir           =>  undef,
1575         cpan_home           =>  undef,
1576         keep_source_where   =>  undef,
1577         histfile            =>  undef,
1578     };
1579     CPAN::FirstTime::init($cpanpm, %args);
1580 }
1581
1582 #-> sub CPAN::Shell::_binary_extensions ;
1583 sub _binary_extensions {
1584     my($self) = shift @_;
1585     my(@result,$module,%seen,%need,$headerdone);
1586     for $module ($self->expand('Module','/./')) {
1587         my $file  = $module->cpan_file;
1588         next if $file eq "N/A";
1589         next if $file =~ /^Contact Author/;
1590         my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
1591         next if $dist->isa_perl;
1592         next unless $module->xs_file;
1593         local($|) = 1;
1594         $CPAN::Frontend->myprint(".");
1595         push @result, $module;
1596     }
1597 #    print join " | ", @result;
1598     $CPAN::Frontend->myprint("\n");
1599     return @result;
1600 }
1601
1602 #-> sub CPAN::Shell::recompile ;
1603 sub recompile {
1604     my($self) = shift @_;
1605     my($module,@module,$cpan_file,%dist);
1606     @module = $self->_binary_extensions();
1607     for $module (@module){  # we force now and compile later, so we
1608                             # don't do it twice
1609         $cpan_file = $module->cpan_file;
1610         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1611         $pack->force;
1612         $dist{$cpan_file}++;
1613     }
1614     for $cpan_file (sort keys %dist) {
1615         $CPAN::Frontend->myprint("  CPAN: Recompiling $cpan_file\n\n");
1616         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1617         $pack->install;
1618         $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1619                            # stop a package from recompiling,
1620                            # e.g. IO-1.12 when we have perl5.003_10
1621     }
1622 }
1623
1624 #-> sub CPAN::Shell::_u_r_common ;
1625 sub _u_r_common {
1626     my($self) = shift @_;
1627     my($what) = shift @_;
1628     CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
1629     Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
1630           $what && $what =~ /^[aru]$/;
1631     my(@args) = @_;
1632     @args = '/./' unless @args;
1633     my(@result,$module,%seen,%need,$headerdone,
1634        $version_undefs,$version_zeroes);
1635     $version_undefs = $version_zeroes = 0;
1636     my $sprintf = "%s%-25s%s %9s %9s  %s\n";
1637     my @expand = $self->expand('Module',@args);
1638     my $expand = scalar @expand;
1639     if (0) { # Looks like noise to me, was very useful for debugging
1640              # for metadata cache
1641         $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
1642     }
1643   MODULE: for $module (@expand) {
1644         my $file  = $module->cpan_file;
1645         next MODULE unless defined $file; # ??
1646         $file =~ s|^./../||;
1647         my($latest) = $module->cpan_version;
1648         my($inst_file) = $module->inst_file;
1649         my($have);
1650         return if $CPAN::Signal;
1651         if ($inst_file){
1652             if ($what eq "a") {
1653                 $have = $module->inst_version;
1654             } elsif ($what eq "r") {
1655                 $have = $module->inst_version;
1656                 local($^W) = 0;
1657                 if ($have eq "undef"){
1658                     $version_undefs++;
1659                 } elsif ($have == 0){
1660                     $version_zeroes++;
1661                 }
1662                 next MODULE unless CPAN::Version->vgt($latest, $have);
1663 # to be pedantic we should probably say:
1664 #    && !($have eq "undef" && $latest ne "undef" && $latest gt "");
1665 # to catch the case where CPAN has a version 0 and we have a version undef
1666             } elsif ($what eq "u") {
1667                 next MODULE;
1668             }
1669         } else {
1670             if ($what eq "a") {
1671                 next MODULE;
1672             } elsif ($what eq "r") {
1673                 next MODULE;
1674             } elsif ($what eq "u") {
1675                 $have = "-";
1676             }
1677         }
1678         return if $CPAN::Signal; # this is sometimes lengthy
1679         $seen{$file} ||= 0;
1680         if ($what eq "a") {
1681             push @result, sprintf "%s %s\n", $module->id, $have;
1682         } elsif ($what eq "r") {
1683             push @result, $module->id;
1684             next MODULE if $seen{$file}++;
1685         } elsif ($what eq "u") {
1686             push @result, $module->id;
1687             next MODULE if $seen{$file}++;
1688             next MODULE if $file =~ /^Contact/;
1689         }
1690         unless ($headerdone++){
1691             $CPAN::Frontend->myprint("\n");
1692             $CPAN::Frontend->myprint(sprintf(
1693                                              $sprintf,
1694                                              "",
1695                                              "Package namespace",
1696                                              "",
1697                                              "installed",
1698                                              "latest",
1699                                              "in CPAN file"
1700                                             ));
1701         }
1702         my $color_on = "";
1703         my $color_off = "";
1704         if (
1705             $COLOR_REGISTERED
1706             &&
1707             $CPAN::META->has_inst("Term::ANSIColor")
1708             &&
1709             $module->description
1710            ) {
1711             $color_on = Term::ANSIColor::color("green");
1712             $color_off = Term::ANSIColor::color("reset");
1713         }
1714         $CPAN::Frontend->myprint(sprintf $sprintf,
1715                                  $color_on,
1716                                  $module->id,
1717                                  $color_off,
1718                                  $have,
1719                                  $latest,
1720                                  $file);
1721         $need{$module->id}++;
1722     }
1723     unless (%need) {
1724         if ($what eq "u") {
1725             $CPAN::Frontend->myprint("No modules found for @args\n");
1726         } elsif ($what eq "r") {
1727             $CPAN::Frontend->myprint("All modules are up to date for @args\n");
1728         }
1729     }
1730     if ($what eq "r") {
1731         if ($version_zeroes) {
1732             my $s_has = $version_zeroes > 1 ? "s have" : " has";
1733             $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
1734                 qq{a version number of 0\n});
1735         }
1736         if ($version_undefs) {
1737             my $s_has = $version_undefs > 1 ? "s have" : " has";
1738             $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
1739                 qq{parseable version number\n});
1740         }
1741     }
1742     @result;
1743 }
1744
1745 #-> sub CPAN::Shell::r ;
1746 sub r {
1747     shift->_u_r_common("r",@_);
1748 }
1749
1750 #-> sub CPAN::Shell::u ;
1751 sub u {
1752     shift->_u_r_common("u",@_);
1753 }
1754
1755 #-> sub CPAN::Shell::failed ;
1756 sub failed {
1757     my($self,$only_id,$silent) = @_;
1758     my @failed;
1759   DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
1760         my $failed = "";
1761         for my $nosayer (
1762                          "writemakefile",
1763                          "signature_verify",
1764                          "make",
1765                          "make_test",
1766                          "install",
1767                         ) {
1768             next unless exists $d->{$nosayer};
1769             next unless (
1770                          $d->{$nosayer}->can("failed") ?
1771                          $d->{$nosayer}->failed :
1772                          $d->{$nosayer} =~ /^NO/
1773                         );
1774             $failed = $nosayer;
1775             last;
1776         }
1777         next DIST unless $failed;
1778         next DIST if $only_id && $only_id != (
1779                                               $d->{$failed}->can("commandid")
1780                                               ?
1781                                               $d->{$failed}->commandid
1782                                               :
1783                                               $CPAN::CurrentCommandId
1784                                              );
1785         my $id = $d->id;
1786         $id =~ s|^./../||;
1787         #$print .= sprintf(
1788         #                  "  %-45s: %s %s\n",
1789         push @failed,
1790             (
1791              $d->{$failed}->can("failed") ?
1792              [
1793               $d->{$failed}->commandid,
1794               $id,
1795               $failed,
1796               $d->{$failed}->text,
1797              ] :
1798              [
1799               1,
1800               $id,
1801               $failed,
1802               $d->{$failed},
1803              ]
1804             );
1805     }
1806     my $scope = $only_id ? "command" : "session";
1807     if (@failed) {
1808         my $print = join "",
1809             map { sprintf "  %-45s: %s %s\n", @$_[1,2,3] }
1810                 sort { $a->[0] <=> $b->[0] } @failed;
1811         $CPAN::Frontend->myprint("Failed during this $scope:\n$print");
1812     } elsif (!$only_id || !$silent) {
1813         $CPAN::Frontend->myprint("Nothing failed in this $scope\n");
1814     }
1815 }
1816
1817 # XXX intentionally undocumented because completely bogus, unportable,
1818 # useless, etc.
1819
1820 #-> sub CPAN::Shell::status ;
1821 sub status {
1822     my($self) = @_;
1823     require Devel::Size;
1824     my $ps = FileHandle->new;
1825     open $ps, "/proc/$$/status";
1826     my $vm = 0;
1827     while (<$ps>) {
1828         next unless /VmSize:\s+(\d+)/;
1829         $vm = $1;
1830         last;
1831     }
1832     $CPAN::Frontend->mywarn(sprintf(
1833                                     "%-27s %6d\n%-27s %6d\n",
1834                                     "vm",
1835                                     $vm,
1836                                     "CPAN::META",
1837                                     Devel::Size::total_size($CPAN::META)/1024,
1838                                    ));
1839     for my $k (sort keys %$CPAN::META) {
1840         next unless substr($k,0,4) eq "read";
1841         warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
1842         for my $k2 (sort keys %{$CPAN::META->{$k}}) {
1843             warn sprintf "  %-25s %6d %6d\n",
1844                 $k2,
1845                     Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
1846                           scalar keys %{$CPAN::META->{$k}{$k2}};
1847         }
1848     }
1849 }
1850
1851 #-> sub CPAN::Shell::autobundle ;
1852 sub autobundle {
1853     my($self) = shift;
1854     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
1855     my(@bundle) = $self->_u_r_common("a",@_);
1856     my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
1857     File::Path::mkpath($todir);
1858     unless (-d $todir) {
1859         $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
1860         return;
1861     }
1862     my($y,$m,$d) =  (localtime)[5,4,3];
1863     $y+=1900;
1864     $m++;
1865     my($c) = 0;
1866     my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
1867     my($to) = File::Spec->catfile($todir,"$me.pm");
1868     while (-f $to) {
1869         $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
1870         $to = File::Spec->catfile($todir,"$me.pm");
1871     }
1872     my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
1873     $fh->print(
1874                "package Bundle::$me;\n\n",
1875                "\$VERSION = '0.01';\n\n",
1876                "1;\n\n",
1877                "__END__\n\n",
1878                "=head1 NAME\n\n",
1879                "Bundle::$me - Snapshot of installation on ",
1880                $Config::Config{'myhostname'},
1881                " on ",
1882                scalar(localtime),
1883                "\n\n=head1 SYNOPSIS\n\n",
1884                "perl -MCPAN -e 'install Bundle::$me'\n\n",
1885                "=head1 CONTENTS\n\n",
1886                join("\n", @bundle),
1887                "\n\n=head1 CONFIGURATION\n\n",
1888                Config->myconfig,
1889                "\n\n=head1 AUTHOR\n\n",
1890                "This Bundle has been generated automatically ",
1891                "by the autobundle routine in CPAN.pm.\n",
1892               );
1893     $fh->close;
1894     $CPAN::Frontend->myprint("\nWrote bundle file
1895     $to\n\n");
1896 }
1897
1898 #-> sub CPAN::Shell::expandany ;
1899 sub expandany {
1900     my($self,$s) = @_;
1901     CPAN->debug("s[$s]") if $CPAN::DEBUG;
1902     if ($s =~ m|/|) { # looks like a file
1903         $s = CPAN::Distribution->normalize($s);
1904         return $CPAN::META->instance('CPAN::Distribution',$s);
1905         # Distributions spring into existence, not expand
1906     } elsif ($s =~ m|^Bundle::|) {
1907         $self->local_bundles; # scanning so late for bundles seems
1908                               # both attractive and crumpy: always
1909                               # current state but easy to forget
1910                               # somewhere
1911         return $self->expand('Bundle',$s);
1912     } else {
1913         return $self->expand('Module',$s)
1914             if $CPAN::META->exists('CPAN::Module',$s);
1915     }
1916     return;
1917 }
1918
1919 #-> sub CPAN::Shell::expand ;
1920 sub expand {
1921     my $self = shift;
1922     my($type,@args) = @_;
1923     CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
1924     my $class = "CPAN::$type";
1925     my $methods = ['id'];
1926     for my $meth (qw(name)) {
1927         next if $] < 5.00303; # no "can"
1928         next unless $class->can($meth);
1929         push @$methods, $meth;
1930     }
1931     $self->expand_by_method($class,$methods,@args);
1932 }
1933
1934 sub expand_by_method {
1935     my $self = shift;
1936     my($class,$methods,@args) = @_;
1937     my($arg,@m);
1938     for $arg (@args) {
1939         my($regex,$command);
1940         if ($arg =~ m|^/(.*)/$|) {
1941             $regex = $1;
1942         } elsif ($arg =~ m/=/) {
1943             $command = 1;
1944         }
1945         my $obj;
1946         CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
1947                     $class,
1948                     defined $regex ? $regex : "UNDEFINED",
1949                     defined $command ? $command : "UNDEFINED",
1950                    ) if $CPAN::DEBUG;
1951         if (defined $regex) {
1952             for $obj (
1953                       $CPAN::META->all_objects($class)
1954                      ) {
1955                 unless ($obj->id){
1956                     # BUG, we got an empty object somewhere
1957                     require Data::Dumper;
1958                     CPAN->debug(sprintf(
1959                                         "Bug in CPAN: Empty id on obj[%s][%s]",
1960                                         $obj,
1961                                         Data::Dumper::Dumper($obj)
1962                                        )) if $CPAN::DEBUG;
1963                     next;
1964                 }
1965                 for my $method (@$methods) {
1966                     if ($obj->$method() =~ /$regex/i) {
1967                         push @m, $obj;
1968                         last;
1969                     }
1970                 }
1971             }
1972         } elsif ($command) {
1973             die "equal sign in command disabled (immature interface), ".
1974                 "you can set
1975  ! \$CPAN::Shell::ADVANCED_QUERY=1
1976 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
1977 that may go away anytime.\n"
1978                     unless $ADVANCED_QUERY;
1979             my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
1980             my($matchcrit) = $criterion =~ m/^~(.+)/;
1981             for my $self (
1982                           sort
1983                           {$a->id cmp $b->id}
1984                           $CPAN::META->all_objects($class)
1985                          ) {
1986                 my $lhs = $self->$method() or next; # () for 5.00503
1987                 if ($matchcrit) {
1988                     push @m, $self if $lhs =~ m/$matchcrit/;
1989                 } else {
1990                     push @m, $self if $lhs eq $criterion;
1991                 }
1992             }
1993         } else {
1994             my($xarg) = $arg;
1995             if ( $class eq 'CPAN::Bundle' ) {
1996                 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
1997             } elsif ($class eq "CPAN::Distribution") {
1998                 $xarg = CPAN::Distribution->normalize($arg);
1999             } else {
2000                 $xarg =~ s/:+/::/g;
2001             }
2002             if ($CPAN::META->exists($class,$xarg)) {
2003                 $obj = $CPAN::META->instance($class,$xarg);
2004             } elsif ($CPAN::META->exists($class,$arg)) {
2005                 $obj = $CPAN::META->instance($class,$arg);
2006             } else {
2007                 next;
2008             }
2009             push @m, $obj;
2010         }
2011     }
2012     @m = sort {$a->id cmp $b->id} @m;
2013     if ( $CPAN::DEBUG ) {
2014         my $wantarray = wantarray;
2015         my $join_m = join ",", map {$_->id} @m;
2016         $self->debug("wantarray[$wantarray]join_m[$join_m]");
2017     }
2018     return wantarray ? @m : $m[0];
2019 }
2020
2021 #-> sub CPAN::Shell::format_result ;
2022 sub format_result {
2023     my($self) = shift;
2024     my($type,@args) = @_;
2025     @args = '/./' unless @args;
2026     my(@result) = $self->expand($type,@args);
2027     my $result = @result == 1 ?
2028         $result[0]->as_string :
2029             @result == 0 ?
2030                 "No objects of type $type found for argument @args\n" :
2031                     join("",
2032                          (map {$_->as_glimpse} @result),
2033                          scalar @result, " items found\n",
2034                         );
2035     $result;
2036 }
2037
2038 #-> sub CPAN::Shell::report_fh ;
2039 {
2040     my $installation_report_fh;
2041     my $previously_noticed = 0;
2042
2043     sub report_fh {
2044         return $installation_report_fh if $installation_report_fh;
2045         if ($CPAN::META->has_inst("File::Temp")) {
2046             $installation_report_fh
2047                 = File::Temp->new(
2048                                   template => 'cpan_install_XXXX',
2049                                   suffix   => '.txt',
2050                                   unlink   => 0,
2051                                  );
2052         }
2053         unless ( $installation_report_fh ) {
2054             warn("Couldn't open installation report file; " .
2055                  "no report file will be generated."
2056                 ) unless $previously_noticed++;
2057         }
2058     }
2059 }
2060
2061
2062 # The only reason for this method is currently to have a reliable
2063 # debugging utility that reveals which output is going through which
2064 # channel. No, I don't like the colors ;-)
2065
2066 #-> sub CPAN::Shell::print_ornameted ;
2067 sub print_ornamented {
2068     my($self,$what,$ornament) = @_;
2069     my $longest = 0;
2070     return unless defined $what;
2071
2072     local $| = 1; # Flush immediately
2073     if ( $CPAN::Be_Silent ) {
2074         print {report_fh()} $what;
2075         return;
2076     }
2077
2078     if ($CPAN::Config->{term_is_latin}){
2079         # courtesy jhi:
2080         $what
2081             =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
2082     }
2083     if ($PRINT_ORNAMENTING) {
2084         unless (defined &color) {
2085             if ($CPAN::META->has_inst("Term::ANSIColor")) {
2086                 import Term::ANSIColor "color";
2087             } else {
2088                 *color = sub { return "" };
2089             }
2090         }
2091         my $line;
2092         for $line (split /\n/, $what) {
2093             $longest = length($line) if length($line) > $longest;
2094         }
2095         my $sprintf = "%-" . $longest . "s";
2096         while ($what){
2097             $what =~ s/(.*\n?)//m;
2098             my $line = $1;
2099             last unless $line;
2100             my($nl) = chomp $line ? "\n" : "";
2101             #   print "line[$line]ornament[$ornament]sprintf[$sprintf]\n";
2102             print color($ornament), sprintf($sprintf,$line), color("reset"), $nl;
2103         }
2104     } else {
2105         # chomp $what;
2106         # $what .= "\n"; # newlines unless $PRINT_ORNAMENTING
2107         print $what;
2108     }
2109 }
2110
2111 sub myprint {
2112     my($self,$what) = @_;
2113
2114     $self->print_ornamented($what, 'bold blue on_yellow');
2115 }
2116
2117 sub myexit {
2118     my($self,$what) = @_;
2119     $self->myprint($what);
2120     exit;
2121 }
2122
2123 sub mywarn {
2124     my($self,$what) = @_;
2125     $self->print_ornamented($what, 'bold red on_yellow');
2126 }
2127
2128 #sub myconfess {
2129 #    my($self,$what) = @_;
2130 #    $self->print_ornamented($what, 'bold red on_white');
2131 #    Carp::confess "died";
2132 #}
2133
2134 sub mydie {
2135     my($self,$what) = @_;
2136     $self->print_ornamented($what, 'bold red on_white');
2137     die "\n";
2138 }
2139
2140 # use this only for unrecoverable errors!
2141 sub unrecoverable_error {
2142     my($self,$what) = @_;
2143     my @lines = split /\n/, $what;
2144     my $longest = 0;
2145     for my $l (@lines) {
2146         $longest = length $l if length $l > $longest;
2147     }
2148     $longest = 62 if $longest > 62;
2149     for my $l (@lines) {
2150         if ($l =~ /^\s*$/){
2151             $l = "\n";
2152             next;
2153         }
2154         $l = "==> $l";
2155         if (length $l < 66) {
2156             $l = pack "A66 A*", $l, "<==";
2157         }
2158         $l .= "\n";
2159     }
2160     unshift @lines, "\n";
2161     $self->mydie(join "", @lines);
2162     die "\n";
2163 }
2164
2165 sub mysleep {
2166     my($self, $sleep) = @_;
2167     sleep $sleep;
2168 }
2169
2170 sub setup_output {
2171     return if -t STDOUT;
2172     my $odef = select STDERR;
2173     $| = 1;
2174     select STDOUT;
2175     $| = 1;
2176     select $odef;
2177 }
2178
2179 #-> sub CPAN::Shell::rematein ;
2180 # RE-adme||MA-ke||TE-st||IN-stall
2181 sub rematein {
2182     my $self = shift;
2183     my($meth,@some) = @_;
2184     my @pragma;
2185     while($meth =~ /^(force|notest)$/) {
2186         push @pragma, $meth;
2187         $meth = shift @some or
2188             $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
2189                                    "cannot continue");
2190     }
2191     setup_output();
2192     CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
2193
2194     # Here is the place to set "test_count" on all involved parties to
2195     # 0. We then can pass this counter on to the involved
2196     # distributions and those can refuse to test if test_count > X. In
2197     # the first stab at it we could use a 1 for "X".
2198
2199     # But when do I reset the distributions to start with 0 again?
2200     # Jost suggested to have a random or cycling interaction ID that
2201     # we pass through. But the ID is something that is just left lying
2202     # around in addition to the counter, so I'd prefer to set the
2203     # counter to 0 now, and repeat at the end of the loop. But what
2204     # about dependencies? They appear later and are not reset, they
2205     # enter the queue but not its copy. How do they get a sensible
2206     # test_count?
2207
2208     # construct the queue
2209     my($s,@s,@qcopy);
2210   STHING: foreach $s (@some) {
2211         my $obj;
2212         if (ref $s) {
2213             CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
2214             $obj = $s;
2215         } elsif ($s =~ m|^/|) { # looks like a regexp
2216             $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
2217                                     "not supported\n");
2218             sleep 2;
2219             next;
2220         } elsif ($meth eq "ls") {
2221             $self->globls($s,\@pragma);
2222             next STHING;
2223         } else {
2224             CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
2225             $obj = CPAN::Shell->expandany($s);
2226         }
2227         if (ref $obj) {
2228             $obj->color_cmd_tmps(0,1);
2229             CPAN::Queue->new($obj->id);
2230             push @qcopy, $obj;
2231         } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
2232             $obj = $CPAN::META->instance('CPAN::Author',uc($s));
2233             if ($meth =~ /^(dump|ls)$/) {
2234                 $obj->$meth();
2235             } else {
2236                 $CPAN::Frontend->myprint(
2237                                          join "",
2238                                          "Don't be silly, you can't $meth ",
2239                                          $obj->fullname,
2240                                          " ;-)\n"
2241                                         );
2242                 sleep 2;
2243             }
2244         } else {
2245             $CPAN::Frontend
2246                 ->myprint(qq{Warning: Cannot $meth $s, }.
2247                           qq{don\'t know what it is.
2248 Try the command
2249
2250     i /$s/
2251
2252 to find objects with matching identifiers.
2253 });
2254             sleep 2;
2255         }
2256     }
2257
2258     # queuerunner (please be warned: when I started to change the
2259     # queue to hold objects instead of names, I made one or two
2260     # mistakes and never found which. I reverted back instead)
2261     while ($s = CPAN::Queue->first) {
2262         my $obj;
2263         if (ref $s) {
2264             $obj = $s; # I do not believe, we would survive if this happened
2265         } else {
2266             $obj = CPAN::Shell->expandany($s);
2267         }
2268         for my $pragma (@pragma) {
2269             if ($pragma
2270                 &&
2271                 ($] < 5.00303 || $obj->can($pragma))){
2272                 ### compatibility with 5.003
2273                 $obj->$pragma($meth); # the pragma "force" in
2274                                       # "CPAN::Distribution" must know
2275                                       # what we are intending
2276             }
2277         }
2278         if ($]>=5.00303 && $obj->can('called_for')) {
2279             $obj->called_for($s);
2280         }
2281         CPAN->debug(
2282                     qq{pragma[@pragma]meth[$meth]obj[$obj]as_string\[}.
2283                     $obj->as_string.
2284                     qq{\]}
2285                    ) if $CPAN::DEBUG;
2286
2287         if ($obj->$meth()){
2288             CPAN::Queue->delete($s);
2289         } else {
2290             CPAN->debug("failed");
2291         }
2292
2293         $obj->undelay;
2294         CPAN::Queue->delete_first($s);
2295     }
2296     for my $obj (@qcopy) {
2297         $obj->color_cmd_tmps(0,0);
2298         delete $obj->{incommandcolor};
2299     }
2300 }
2301
2302 #-> sub CPAN::Shell::recent ;
2303 sub recent {
2304   my($self) = @_;
2305
2306   CPAN::Distribution::_display_url( $self, $CPAN::Defaultrecent );
2307   return;
2308 }
2309
2310 {
2311     # set up the dispatching methods
2312     no strict "refs";
2313     for my $command (qw(
2314                         clean
2315                         cvs_import
2316                         dump
2317                         force
2318                         get
2319                         install
2320                         look
2321                         ls
2322                         make
2323                         notest
2324                         perldoc
2325                         readme
2326                         test
2327                        )) {
2328         *$command = sub { shift->rematein($command, @_); };
2329     }
2330 }
2331
2332 package CPAN::LWP::UserAgent;
2333 use strict;
2334
2335 sub config {
2336     return if $SETUPDONE;
2337     if ($CPAN::META->has_usable('LWP::UserAgent')) {
2338         require LWP::UserAgent;
2339         @ISA = qw(Exporter LWP::UserAgent);
2340         $SETUPDONE++;
2341     } else {
2342         $CPAN::Frontend->mywarn("LWP::UserAgent not available\n");
2343     }
2344 }
2345
2346 sub get_basic_credentials {
2347     my($self, $realm, $uri, $proxy) = @_;
2348     return unless $proxy;
2349     if ($USER && $PASSWD) {
2350     } elsif (defined $CPAN::Config->{proxy_user} &&
2351              defined $CPAN::Config->{proxy_pass}) {
2352         $USER = $CPAN::Config->{proxy_user};
2353         $PASSWD = $CPAN::Config->{proxy_pass};
2354     } else {
2355         require ExtUtils::MakeMaker;
2356         ExtUtils::MakeMaker->import(qw(prompt));
2357         $USER = prompt("Proxy authentication needed!
2358  (Note: to permanently configure username and password run
2359    o conf proxy_user your_username
2360    o conf proxy_pass your_password
2361  )\nUsername:");
2362         if ($CPAN::META->has_inst("Term::ReadKey")) {
2363             Term::ReadKey::ReadMode("noecho");
2364         } else {
2365             $CPAN::Frontend->mywarn("Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n");
2366         }
2367         $PASSWD = prompt("Password:");
2368         if ($CPAN::META->has_inst("Term::ReadKey")) {
2369             Term::ReadKey::ReadMode("restore");
2370         }
2371         $CPAN::Frontend->myprint("\n\n");
2372     }
2373     return($USER,$PASSWD);
2374 }
2375
2376 # mirror(): Its purpose is to deal with proxy authentication. When we
2377 # call SUPER::mirror, we relly call the mirror method in
2378 # LWP::UserAgent. LWP::UserAgent will then call
2379 # $self->get_basic_credentials or some equivalent and this will be
2380 # $self->dispatched to our own get_basic_credentials method.
2381
2382 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
2383
2384 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
2385 # although we have gone through our get_basic_credentials, the proxy
2386 # server refuses to connect. This could be a case where the username or
2387 # password has changed in the meantime, so I'm trying once again without
2388 # $USER and $PASSWD to give the get_basic_credentials routine another
2389 # chance to set $USER and $PASSWD.
2390
2391 # mirror(): Its purpose is to deal with proxy authentication. When we
2392 # call SUPER::mirror, we relly call the mirror method in
2393 # LWP::UserAgent. LWP::UserAgent will then call
2394 # $self->get_basic_credentials or some equivalent and this will be
2395 # $self->dispatched to our own get_basic_credentials method.
2396
2397 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
2398
2399 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
2400 # although we have gone through our get_basic_credentials, the proxy
2401 # server refuses to connect. This could be a case where the username or
2402 # password has changed in the meantime, so I'm trying once again without
2403 # $USER and $PASSWD to give the get_basic_credentials routine another
2404 # chance to set $USER and $PASSWD.
2405
2406 sub mirror {
2407     my($self,$url,$aslocal) = @_;
2408     my $result = $self->SUPER::mirror($url,$aslocal);
2409     if ($result->code == 407) {
2410         undef $USER;
2411         undef $PASSWD;
2412         $result = $self->SUPER::mirror($url,$aslocal);
2413     }
2414     $result;
2415 }
2416
2417 package CPAN::FTP;
2418 use strict;
2419
2420 #-> sub CPAN::FTP::ftp_get ;
2421 sub ftp_get {
2422     my($class,$host,$dir,$file,$target) = @_;
2423     $class->debug(
2424                   qq[Going to fetch file [$file] from dir [$dir]
2425         on host [$host] as local [$target]\n]
2426                  ) if $CPAN::DEBUG;
2427     my $ftp = Net::FTP->new($host);
2428     unless ($ftp) {
2429         $CPAN::Frontend->mywarn("  Could not connect to host '$host' with Net::FTP\n");
2430         return;
2431     }
2432     return 0 unless defined $ftp;
2433     $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
2434     $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
2435     unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
2436         my $msg = $ftp->message;
2437         $CPAN::Frontend->mywarn("  Couldn't login on $host: $msg");
2438         return;
2439     }
2440     unless ( $ftp->cwd($dir) ){
2441         my $msg = $ftp->message;
2442         $CPAN::Frontend->mywarn("  Couldn't cwd $dir: $msg");
2443         return;
2444     }
2445     $ftp->binary;
2446     $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
2447     unless ( $ftp->get($file,$target) ){
2448         my $msg = $ftp->message;
2449         $CPAN::Frontend->mywarn("  Couldn't fetch $file from $host: $msg");
2450         return;
2451     }
2452     $ftp->quit; # it's ok if this fails
2453     return 1;
2454 }
2455
2456 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
2457
2458  # > *** /install/perl/live/lib/CPAN.pm-        Wed Sep 24 13:08:48 1997
2459  # > --- /tmp/cp        Wed Sep 24 13:26:40 1997
2460  # > ***************
2461  # > *** 1562,1567 ****
2462  # > --- 1562,1580 ----
2463  # >       return 1 if substr($url,0,4) eq "file";
2464  # >       return 1 unless $url =~ m|://([^/]+)|;
2465  # >       my $host = $1;
2466  # > +     my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
2467  # > +     if ($proxy) {
2468  # > +         $proxy =~ m|://([^/:]+)|;
2469  # > +         $proxy = $1;
2470  # > +         my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
2471  # > +         if ($noproxy) {
2472  # > +             if ($host !~ /$noproxy$/) {
2473  # > +                 $host = $proxy;
2474  # > +             }
2475  # > +         } else {
2476  # > +             $host = $proxy;
2477  # > +         }
2478  # > +     }
2479  # >       require Net::Ping;
2480  # >       return 1 unless $Net::Ping::VERSION >= 2;
2481  # >       my $p;
2482
2483
2484 #-> sub CPAN::FTP::localize ;
2485 sub localize {
2486     my($self,$file,$aslocal,$force) = @_;
2487     $force ||= 0;
2488     Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
2489         unless defined $aslocal;
2490     $self->debug("file[$file] aslocal[$aslocal] force[$force]")
2491         if $CPAN::DEBUG;
2492
2493     if ($^O eq 'MacOS') {
2494         # Comment by AK on 2000-09-03: Uniq short filenames would be
2495         # available in CHECKSUMS file
2496         my($name, $path) = File::Basename::fileparse($aslocal, '');
2497         if (length($name) > 31) {
2498             $name =~ s/(
2499                         \.(
2500                            readme(\.(gz|Z))? |
2501                            (tar\.)?(gz|Z) |
2502                            tgz |
2503                            zip |
2504                            pm\.(gz|Z)
2505                           )
2506                        )$//x;
2507             my $suf = $1;
2508             my $size = 31 - length($suf);
2509             while (length($name) > $size) {
2510                 chop $name;
2511             }
2512             $name .= $suf;
2513             $aslocal = File::Spec->catfile($path, $name);
2514         }
2515     }
2516
2517     if (-f $aslocal && -r _ && !($force & 1)){
2518       if (-s $aslocal) {
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 Bundle::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::set ;
3817 sub set {
3818     my($self,%att) = @_;
3819     my $class = ref $self;
3820
3821     # This must be ||=, not ||, because only if we write an empty
3822     # reference, only then the set method will write into the readonly
3823     # area. But for Distributions that spring into existence, maybe
3824     # because of a typo, we do not like it that they are written into
3825     # the readonly area and made permanent (at least for a while) and
3826     # that is why we do not "allow" other places to call ->set.
3827     unless ($self->id) {
3828         CPAN->debug("Bug? Empty ID, rejecting");
3829         return;
3830     }
3831     my $ro = $self->{RO} =
3832         $CPAN::META->{readonly}{$class}{$self->id} ||= {};
3833
3834     while (my($k,$v) = each %att) {
3835         $ro->{$k} = $v;
3836     }
3837 }
3838
3839 #-> sub CPAN::InfoObj::as_glimpse ;
3840 sub as_glimpse {
3841     my($self) = @_;
3842     my(@m);
3843     my $class = ref($self);
3844     $class =~ s/^CPAN:://;
3845     push @m, sprintf "%-15s %s\n", $class, $self->{ID};
3846     join "", @m;
3847 }
3848
3849 #-> sub CPAN::InfoObj::as_string ;
3850 sub as_string {
3851     my($self) = @_;
3852     my(@m);
3853     my $class = ref($self);
3854     $class =~ s/^CPAN:://;
3855     push @m, $class, " id = $self->{ID}\n";
3856     my $ro;
3857     unless ($ro = $self->ro) {
3858         $CPAN::Frontend->mydie("Unknown distribution $self->{ID}");
3859     }
3860     for (sort keys %$ro) {
3861         # next if m/^(ID|RO)$/;
3862         my $extra = "";
3863         if ($_ eq "CPAN_USERID") {
3864             $extra .= " (";
3865             $extra .= $self->fullname;
3866             my $email; # old perls!
3867             if ($email = $CPAN::META->instance("CPAN::Author",
3868                                                $self->cpan_userid
3869                                               )->email) {
3870                 $extra .= " <$email>";
3871             } else {
3872                 $extra .= " <no email>";
3873             }
3874             $extra .= ")";
3875         } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
3876             push @m, sprintf "    %-12s %s\n", $_, $self->fullname;
3877             next;
3878         }
3879         next unless defined $ro->{$_};
3880         push @m, sprintf "    %-12s %s%s\n", $_, $ro->{$_}, $extra;
3881     }
3882     for (sort keys %$self) {
3883         next if m/^(ID|RO)$/;
3884         if (ref($self->{$_}) eq "ARRAY") {
3885           push @m, sprintf "    %-12s %s\n", $_, "@{$self->{$_}}";
3886         } elsif (ref($self->{$_}) eq "HASH") {
3887           push @m, sprintf(
3888                            "    %-12s %s\n",
3889                            $_,
3890                            join(" ",sort keys %{$self->{$_}}),
3891                           );
3892         } else {
3893           push @m, sprintf "    %-12s %s\n", $_, $self->{$_};
3894         }
3895     }
3896     join "", @m, "\n";
3897 }
3898
3899 #-> sub CPAN::InfoObj::fullname ;
3900 sub fullname {
3901     my($self) = @_;
3902     $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
3903 }
3904
3905 #-> sub CPAN::InfoObj::dump ;
3906 sub dump {
3907   my($self) = @_;
3908   require Data::Dumper;
3909   local $Data::Dumper::Sortkeys;
3910   $Data::Dumper::Sortkeys = 1;
3911   print Data::Dumper::Dumper($self);
3912 }
3913
3914 package CPAN::Author;
3915 use strict;
3916
3917 #-> sub CPAN::Author::force
3918 sub force {
3919     my $self = shift;
3920     $self->{force}++;
3921 }
3922
3923 #-> sub CPAN::Author::force
3924 sub unforce {
3925     my $self = shift;
3926     delete $self->{force};
3927 }
3928
3929 #-> sub CPAN::Author::id
3930 sub id {
3931     my $self = shift;
3932     my $id = $self->{ID};
3933     $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
3934     $id;
3935 }
3936
3937 #-> sub CPAN::Author::as_glimpse ;
3938 sub as_glimpse {
3939     my($self) = @_;
3940     my(@m);
3941     my $class = ref($self);
3942     $class =~ s/^CPAN:://;
3943     push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
3944                      $class,
3945                      $self->{ID},
3946                      $self->fullname,
3947                      $self->email);
3948     join "", @m;
3949 }
3950
3951 #-> sub CPAN::Author::fullname ;
3952 sub fullname {
3953     shift->ro->{FULLNAME};
3954 }
3955 *name = \&fullname;
3956
3957 #-> sub CPAN::Author::email ;
3958 sub email    { shift->ro->{EMAIL}; }
3959
3960 #-> sub CPAN::Author::ls ;
3961 sub ls {
3962     my $self = shift;
3963     my $glob = shift || "";
3964     my $silent = shift || 0;
3965     my $id = $self->id;
3966
3967     # adapted from CPAN::Distribution::verifyCHECKSUM ;
3968     my(@csf); # chksumfile
3969     @csf = $self->id =~ /(.)(.)(.*)/;
3970     $csf[1] = join "", @csf[0,1];
3971     $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
3972     my(@dl);
3973     @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
3974     unless (grep {$_->[2] eq $csf[1]} @dl) {
3975         $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
3976         return;
3977     }
3978     @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
3979     unless (grep {$_->[2] eq $csf[2]} @dl) {
3980         $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
3981         return;
3982     }
3983     @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
3984     if ($glob) {
3985         if ($CPAN::META->has_inst("Text::Glob")) {
3986             my $rglob = Text::Glob::glob_to_regex($glob);
3987             @dl = grep { $_->[2] =~ /$rglob/ } @dl;
3988         } else {
3989             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
3990         }
3991     }
3992     $CPAN::Frontend->myprint(join "", map {
3993         sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
3994     } sort { $a->[2] cmp $b->[2] } @dl);
3995     @dl;
3996 }
3997
3998 # returns an array of arrays, the latter contain (size,mtime,filename)
3999 #-> sub CPAN::Author::dir_listing ;
4000 sub dir_listing {
4001     my $self = shift;
4002     my $chksumfile = shift;
4003     my $recursive = shift;
4004     my $may_ftp = shift;
4005     my $lc_want =
4006         File::Spec->catfile($CPAN::Config->{keep_source_where},
4007                             "authors", "id", @$chksumfile);
4008
4009     my $fh;
4010
4011     # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
4012     # hazard.  (Without GPG installed they are not that much better,
4013     # though.)
4014     $fh = FileHandle->new;
4015     if (open($fh, $lc_want)) {
4016         my $line = <$fh>; close $fh;
4017         unlink($lc_want) unless $line =~ /PGP/;
4018     }
4019
4020     local($") = "/";
4021     # connect "force" argument with "index_expire".
4022     my $force = $self->{force};
4023     if (my @stat = stat $lc_want) {
4024         $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
4025     }
4026     my $lc_file;
4027     if ($may_ftp) {
4028         $lc_file = CPAN::FTP->localize(
4029                                        "authors/id/@$chksumfile",
4030                                        $lc_want,
4031                                        $force,
4032                                       );
4033         unless ($lc_file) {
4034             $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
4035             $chksumfile->[-1] .= ".gz";
4036             $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
4037                                            "$lc_want.gz",1);
4038             if ($lc_file) {
4039                 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
4040                 CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file);
4041             } else {
4042                 return;
4043             }
4044         }
4045     } else {
4046         $lc_file = $lc_want;
4047         # we *could* second-guess and if the user has a file: URL,
4048         # then we could look there. But on the other hand, if they do
4049         # have a file: URL, wy did they choose to set
4050         # $CPAN::Config->{show_upload_date} to false?
4051     }
4052
4053     # adapted from CPAN::Distribution::CHECKSUM_check_file ;
4054     $fh = FileHandle->new;
4055     my($cksum);
4056     if (open $fh, $lc_file){
4057         local($/);
4058         my $eval = <$fh>;
4059         $eval =~ s/\015?\012/\n/g;
4060         close $fh;
4061         my($comp) = Safe->new();
4062         $cksum = $comp->reval($eval);
4063         if ($@) {
4064             rename $lc_file, "$lc_file.bad";
4065             Carp::confess($@) if $@;
4066         }
4067     } elsif ($may_ftp) {
4068         Carp::carp "Could not open $lc_file for reading.";
4069     } else {
4070         # Maybe should warn: "You may want to set show_upload_date to a true value"
4071         return;
4072     }
4073     my(@result,$f);
4074     for $f (sort keys %$cksum) {
4075         if (exists $cksum->{$f}{isdir}) {
4076             if ($recursive) {
4077                 my(@dir) = @$chksumfile;
4078                 pop @dir;
4079                 push @dir, $f, "CHECKSUMS";
4080                 push @result, map {
4081                     [$_->[0], $_->[1], "$f/$_->[2]"]
4082                 } $self->dir_listing(\@dir,1,$may_ftp);
4083             } else {
4084                 push @result, [ 0, "-", $f ];
4085             }
4086         } else {
4087             push @result, [
4088                            ($cksum->{$f}{"size"}||0),
4089                            $cksum->{$f}{"mtime"}||"---",
4090                            $f
4091                           ];
4092         }
4093     }
4094     @result;
4095 }
4096
4097 package CPAN::Distribution;
4098 use strict;
4099
4100 # Accessors
4101 sub cpan_comment {
4102     my $self = shift;
4103     my $ro = $self->ro or return;
4104     $ro->{CPAN_COMMENT}
4105 }
4106
4107 # CPAN::Distribution::undelay
4108 sub undelay {
4109     my $self = shift;
4110     delete $self->{later};
4111 }
4112
4113 # add the A/AN/ stuff
4114 # CPAN::Distribution::normalize
4115 sub normalize {
4116     my($self,$s) = @_;
4117     $s = $self->id unless defined $s;
4118     if (
4119         $s =~ tr|/|| == 1
4120         or
4121         $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
4122        ) {
4123         return $s if $s =~ m:^N/A|^Contact Author: ;
4124         $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
4125             $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
4126         CPAN->debug("s[$s]") if $CPAN::DEBUG;
4127     }
4128     $s;
4129 }
4130
4131 #-> sub CPAN::Distribution::author ;
4132 sub author {
4133     my($self) = @_;
4134     my($authorid) = $self->pretty_id =~ /^([\w\-]+)/;
4135     CPAN::Shell->expand("Author",$authorid);
4136 }
4137
4138 # tries to get the yaml from CPAN instead of the distro itself:
4139 # EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels
4140 sub fast_yaml {
4141     my($self) = @_;
4142     my $meta = $self->pretty_id;
4143     $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/;
4144     my(@ls) = CPAN::Shell->globls($meta);
4145     my $norm = $self->normalize($meta);
4146
4147     my($local_file);
4148     my($local_wanted) =
4149         File::Spec->catfile(
4150                             $CPAN::Config->{keep_source_where},
4151                             "authors",
4152                             "id",
4153                             split(/\//,$norm)
4154                            );
4155     $self->debug("Doing localize") if $CPAN::DEBUG;
4156     unless ($local_file =
4157             CPAN::FTP->localize("authors/id/$norm",
4158                                 $local_wanted)) {
4159         $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n");
4160     }
4161     if ($CPAN::META->has_inst("YAML")) {
4162         my $yaml = YAML::LoadFile($local_file);
4163         return $yaml;
4164     } else {
4165         $CPAN::Frontend->mydie("Yaml not installed, cannot parse '$local_file'\n");
4166     }
4167 }
4168
4169 sub pretty_id {
4170     my $self = shift;
4171     my $id = $self->id;
4172     return $id unless $id =~ m|^./../|;
4173     substr($id,5);
4174 }
4175
4176 # mark as dirty/clean
4177 #-> sub CPAN::Distribution::color_cmd_tmps ;
4178 sub color_cmd_tmps {
4179     my($self) = shift;
4180     my($depth) = shift || 0;
4181     my($color) = shift || 0;
4182     my($ancestors) = shift || [];
4183     # a distribution needs to recurse into its prereq_pms
4184
4185     return if exists $self->{incommandcolor}
4186         && $self->{incommandcolor}==$color;
4187     if ($depth>=100){
4188         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
4189     }
4190     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
4191     my $prereq_pm = $self->prereq_pm;
4192     if (defined $prereq_pm) {
4193       PREREQ: for my $pre (keys %$prereq_pm) {
4194             my $premo;
4195             unless ($premo = CPAN::Shell->expand("Module",$pre)) {
4196                 $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n");
4197                 $CPAN::Frontend->mysleep(2);
4198                 next PREREQ;
4199             }
4200             $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
4201         }
4202     }
4203     if ($color==0) {
4204         delete $self->{sponsored_mods};
4205         delete $self->{badtestcnt};
4206     }
4207     $self->{incommandcolor} = $color;
4208 }
4209
4210 #-> sub CPAN::Distribution::as_string ;
4211 sub as_string {
4212   my $self = shift;
4213   $self->containsmods;
4214   $self->upload_date;
4215   $self->SUPER::as_string(@_);
4216 }
4217
4218 #-> sub CPAN::Distribution::containsmods ;
4219 sub containsmods {
4220   my $self = shift;
4221   return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
4222   my $dist_id = $self->{ID};
4223   for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
4224     my $mod_file = $mod->cpan_file or next;
4225     my $mod_id = $mod->{ID} or next;
4226     # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
4227     # sleep 1;
4228     $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
4229   }
4230   keys %{$self->{CONTAINSMODS}};
4231 }
4232
4233 #-> sub CPAN::Distribution::upload_date ;
4234 sub upload_date {
4235   my $self = shift;
4236   return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
4237   my(@local_wanted) = split(/\//,$self->id);
4238   my $filename = pop @local_wanted;
4239   push @local_wanted, "CHECKSUMS";
4240   my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
4241   return unless $author;
4242   my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
4243   return unless @dl;
4244   my($dirent) = grep { $_->[2] eq $filename } @dl;
4245   # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
4246   return unless $dirent->[1];
4247   return $self->{UPLOAD_DATE} = $dirent->[1];
4248 }
4249
4250 #-> sub CPAN::Distribution::uptodate ;
4251 sub uptodate {
4252     my($self) = @_;
4253     my $c;
4254     foreach $c ($self->containsmods) {
4255         my $obj = CPAN::Shell->expandany($c);
4256         return 0 unless $obj->uptodate;
4257     }
4258     return 1;
4259 }
4260
4261 #-> sub CPAN::Distribution::called_for ;
4262 sub called_for {
4263     my($self,$id) = @_;
4264     $self->{CALLED_FOR} = $id if defined $id;
4265     return $self->{CALLED_FOR};
4266 }
4267
4268 #-> sub CPAN::Distribution::safe_chdir ;
4269 sub safe_chdir {
4270   my($self,$todir) = @_;
4271   # we die if we cannot chdir and we are debuggable
4272   Carp::confess("safe_chdir called without todir argument")
4273         unless defined $todir and length $todir;
4274   if (chdir $todir) {
4275     $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
4276         if $CPAN::DEBUG;
4277   } else {
4278     if (-e $todir) {
4279         unless (-x $todir) {
4280             unless (chmod 0755, $todir) {
4281                 my $cwd = CPAN::anycwd();
4282                 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
4283                                         "permission to change the permission; cannot ".
4284                                         "chdir to '$todir'\n");
4285                 $CPAN::Frontend->mysleep(5);
4286                 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
4287                                        qq{to todir[$todir]: $!});
4288             }
4289         }
4290     } else {
4291         $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n");
4292     }
4293     if (chdir $todir) {
4294       $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
4295           if $CPAN::DEBUG;
4296     } else {
4297       my $cwd = CPAN::anycwd();
4298       $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
4299                              qq{to todir[$todir] (a chmod has been issued): $!});
4300     }
4301   }
4302 }
4303
4304 #-> sub CPAN::Distribution::get ;
4305 sub get {
4306     my($self) = @_;
4307   EXCUSE: {
4308         my @e;
4309         exists $self->{'build_dir'} and push @e,
4310             "Is already unwrapped into directory $self->{'build_dir'}";
4311         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
4312     }
4313     my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
4314
4315     #
4316     # Get the file on local disk
4317     #
4318
4319     my($local_file);
4320     my($local_wanted) =
4321         File::Spec->catfile(
4322                             $CPAN::Config->{keep_source_where},
4323                             "authors",
4324                             "id",
4325                             split(/\//,$self->id)
4326                            );
4327
4328     $self->debug("Doing localize") if $CPAN::DEBUG;
4329     unless ($local_file =
4330             CPAN::FTP->localize("authors/id/$self->{ID}",
4331                                 $local_wanted)) {
4332         my $note = "";
4333         if ($CPAN::Index::DATE_OF_02) {
4334             $note = "Note: Current database in memory was generated ".
4335                 "on $CPAN::Index::DATE_OF_02\n";
4336         }
4337         $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
4338     }
4339     $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
4340     $self->{localfile} = $local_file;
4341     return if $CPAN::Signal;
4342
4343     #
4344     # Check integrity
4345     #
4346     if ($CPAN::META->has_inst("Digest::SHA")) {
4347         $self->debug("Digest::SHA is installed, verifying");
4348         $self->verifyCHECKSUM;
4349     } else {
4350         $self->debug("Digest::SHA is NOT installed");
4351     }
4352     return if $CPAN::Signal;
4353
4354     #
4355     # Create a clean room and go there
4356     #
4357     $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
4358     my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
4359     $self->safe_chdir($builddir);
4360     $self->debug("Removing tmp") if $CPAN::DEBUG;
4361     File::Path::rmtree("tmp");
4362     unless (mkdir "tmp", 0755) {
4363         $CPAN::Frontend->unrecoverable_error(<<EOF);
4364 Couldn't mkdir '$builddir/tmp': $!
4365
4366 Cannot continue: Please find the reason why I cannot make the
4367 directory
4368 $builddir/tmp
4369 and fix the problem, then retry.
4370
4371 EOF
4372     }
4373     if ($CPAN::Signal){
4374         $self->safe_chdir($sub_wd);
4375         return;
4376     }
4377     $self->safe_chdir("tmp");
4378
4379     #
4380     # Unpack the goods
4381     #
4382     $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
4383     my $ct = CPAN::Tarzip->new($local_file);
4384     if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i){
4385         $self->{was_uncompressed}++ unless $ct->gtest();
4386         $self->untar_me($ct);
4387     } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
4388         $self->unzip_me($ct);
4389     } elsif ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/) {
4390         $self->{was_uncompressed}++ unless $ct->gtest();
4391         $self->debug("calling pm2dir for local_file[$local_file]") if $CPAN::DEBUG;
4392         $self->pm2dir_me($local_file);
4393     } else {
4394         $self->{archived} = "NO";
4395         $self->safe_chdir($sub_wd);
4396         return;
4397     }
4398
4399     # we are still in the tmp directory!
4400     # Let's check if the package has its own directory.
4401     my $dh = DirHandle->new(File::Spec->curdir)
4402         or Carp::croak("Couldn't opendir .: $!");
4403     my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
4404     $dh->close;
4405     my ($distdir,$packagedir);
4406     if (@readdir == 1 && -d $readdir[0]) {
4407         $distdir = $readdir[0];
4408         $packagedir = File::Spec->catdir($builddir,$distdir);
4409         $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
4410             if $CPAN::DEBUG;
4411         -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
4412                                                     "$packagedir\n");
4413         File::Path::rmtree($packagedir);
4414         unless (File::Copy::move($distdir,$packagedir)) {
4415             $CPAN::Frontend->unrecoverable_error(<<EOF);
4416 Couldn't move '$distdir' to '$packagedir': $!
4417
4418 Cannot continue: Please find the reason why I cannot move
4419 $builddir/tmp/$distdir
4420 to
4421 $packagedir
4422 and fix the problem, then retry
4423
4424 EOF
4425         }
4426         $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
4427                              $distdir,
4428                              $packagedir,
4429                              -e $packagedir,
4430                              -d $packagedir,
4431                             )) if $CPAN::DEBUG;
4432     } else {
4433         my $userid = $self->cpan_userid;
4434         unless ($userid) {
4435             CPAN->debug("no userid? self[$self]");
4436             $userid = "anon";
4437         }
4438         my $pragmatic_dir = $userid . '000';
4439         $pragmatic_dir =~ s/\W_//g;
4440         $pragmatic_dir++ while -d "../$pragmatic_dir";
4441         $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
4442         $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
4443         File::Path::mkpath($packagedir);
4444         my($f);
4445         for $f (@readdir) { # is already without "." and ".."
4446             my $to = File::Spec->catdir($packagedir,$f);
4447             File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
4448         }
4449     }
4450     if ($CPAN::Signal){
4451         $self->safe_chdir($sub_wd);
4452         return;
4453     }
4454
4455     $self->{'build_dir'} = $packagedir;
4456     $self->safe_chdir($builddir);
4457     File::Path::rmtree("tmp");
4458
4459     $self->safe_chdir($packagedir);
4460     if ($CPAN::META->has_inst("Module::Signature")) {
4461         if (-f "SIGNATURE") {
4462             $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
4463             my $rv = Module::Signature::verify();
4464             if ($rv != Module::Signature::SIGNATURE_OK() and
4465                 $rv != Module::Signature::SIGNATURE_MISSING()) {
4466                 $CPAN::Frontend->myprint(
4467                                          qq{\nSignature invalid for }.
4468                                          qq{distribution file. }.
4469                                          qq{Please investigate.\n\n}.
4470                                          $self->as_string,
4471                                          $CPAN::META->instance(
4472                                                                'CPAN::Author',
4473                                                                $self->cpan_userid,
4474                                                               )->as_string
4475                                         );
4476
4477                 my $wrap =
4478                     sprintf(qq{I'd recommend removing %s. Its signature
4479 is invalid. Maybe you have configured your 'urllist' with
4480 a bad URL. Please check this array with 'o conf urllist', and
4481 retry. For more information, try opening a subshell with
4482   look %s
4483 and there run
4484   cpansign -v
4485 },
4486                             $self->{localfile},
4487                             $self->pretty_id,
4488                            );
4489                 $self->{signature_verify} = CPAN::Distrostatus->new("NO");