lib/CPAN.pm

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