lib/CPAN.pm

   1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
   2 use strict;
   3 package CPAN;
   4 $CPAN::VERSION = '1.88_51';
   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:\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     return 1 unless $INC{$f}; # we never loaded this, so we do not
1551                               # reload but say OK
1552     my $pwd = CPAN::anycwd();
1553     CPAN->debug("reloading the whole '$f' from '$INC{$f}' while pwd='$pwd'")
1554         if $CPAN::DEBUG;
1555     my $read;
1556     for my $inc (@INC) {
1557         $read = File::Spec->catfile($inc,split /\//, $f);
1558         last if -f $read;
1559     }
1560     unless (-f $read) {
1561         $read = $INC{$f};
1562     }
1563     unless (-f $read) {
1564         $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
1565         return;
1566     }
1567     my $fh = FileHandle->new($read) or
1568         $CPAN::Frontend->mydie("Could not open $read: $!");
1569     local($/);
1570     local $^W = 1;
1571     my $eval = <$fh>;
1572     CPAN->debug(sprintf("evaling [%s...]\n",substr($eval,0,64)))
1573         if $CPAN::DEBUG;
1574     eval $eval;
1575     if ($@){
1576         warn $@;
1577         return;
1578     }
1579     return 1;
1580 }
1581
1582 #-> sub CPAN::Shell::mkmyconfig ;
1583 sub mkmyconfig {
1584     my($self, $cpanpm, %args) = @_;
1585     require CPAN::FirstTime;
1586     my $home = CPAN::HandleConfig::home;
1587     $cpanpm = $INC{'CPAN/MyConfig.pm'} ||
1588         File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm");
1589     File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm;
1590     CPAN::HandleConfig::require_myconfig_or_config;
1591     $CPAN::Config ||= {};
1592     $CPAN::Config = {
1593         %$CPAN::Config,
1594         build_dir           =>  undef,
1595         cpan_home           =>  undef,
1596         keep_source_where   =>  undef,
1597         histfile            =>  undef,
1598     };
1599     CPAN::FirstTime::init($cpanpm, %args);
1600 }
1601
1602 #-> sub CPAN::Shell::_binary_extensions ;
1603 sub _binary_extensions {
1604     my($self) = shift @_;
1605     my(@result,$module,%seen,%need,$headerdone);
1606     for $module ($self->expand('Module','/./')) {
1607         my $file  = $module->cpan_file;
1608         next if $file eq "N/A";
1609         next if $file =~ /^Contact Author/;
1610         my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
1611         next if $dist->isa_perl;
1612         next unless $module->xs_file;
1613         local($|) = 1;
1614         $CPAN::Frontend->myprint(".");
1615         push @result, $module;
1616     }
1617 #    print join " | ", @result;
1618     $CPAN::Frontend->myprint("\n");
1619     return @result;
1620 }
1621
1622 #-> sub CPAN::Shell::recompile ;
1623 sub recompile {
1624     my($self) = shift @_;
1625     my($module,@module,$cpan_file,%dist);
1626     @module = $self->_binary_extensions();
1627     for $module (@module){  # we force now and compile later, so we
1628                             # don't do it twice
1629         $cpan_file = $module->cpan_file;
1630         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1631         $pack->force;
1632         $dist{$cpan_file}++;
1633     }
1634     for $cpan_file (sort keys %dist) {
1635         $CPAN::Frontend->myprint("  CPAN: Recompiling $cpan_file\n\n");
1636         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1637         $pack->install;
1638         $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1639                            # stop a package from recompiling,
1640                            # e.g. IO-1.12 when we have perl5.003_10
1641     }
1642 }
1643
1644 #-> sub CPAN::Shell::scripts ;
1645 sub scripts {
1646     my($self, $arg) = @_;
1647     $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");
1648
1649     for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) {
1650         unless ($CPAN::META->has_inst($req)) {
1651             $CPAN::Frontend->mywarn("  $req not available\n");
1652         }
1653     }
1654     my $p = HTML::LinkExtor->new();
1655     my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html";
1656     unless (-f $indexfile) {
1657         $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n");
1658     }
1659     $p->parse_file($indexfile);
1660     my @hrefs;
1661     my $qrarg;
1662     if ($arg =~ s|^/(.+)/$|$1|) {
1663         $qrarg = eval 'qr/$arg/'; # hide construct from 5.004
1664     }
1665     for my $l ($p->links) {
1666         my $tag = shift @$l;
1667         next unless $tag eq "a";
1668         my %att = @$l;
1669         my $href = $att{href};
1670         next unless $href =~ s|^\.\./authors/id/./../||;
1671         if ($arg) {
1672             if ($qrarg) {
1673                 if ($href =~ $qrarg) {
1674                     push @hrefs, $href;
1675                 }
1676             } else {
1677                 if ($href =~ /\Q$arg\E/) {
1678                     push @hrefs, $href;
1679                 }
1680             }
1681         } else {
1682             push @hrefs, $href;
1683         }
1684     }
1685     # now filter for the latest version if there is more than one of a name
1686     my %stems;
1687     for (sort @hrefs) {
1688         my $href = $_;
1689         s/-v?\d.*//;
1690         my $stem = $_;
1691         $stems{$stem} ||= [];
1692         push @{$stems{$stem}}, $href;
1693     }
1694     for (sort keys %stems) {
1695         my $highest;
1696         if (@{$stems{$_}} > 1) {
1697             $highest = List::Util::reduce {
1698                 Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b
1699               } @{$stems{$_}};
1700         } else {
1701             $highest = $stems{$_}[0];
1702         }
1703         $CPAN::Frontend->myprint("$highest\n");
1704     }
1705 }
1706
1707 #-> sub CPAN::Shell::upgrade ;
1708 sub upgrade {
1709     my($self,@args) = @_;
1710     $self->install($self->r(@args));
1711 }
1712
1713 #-> sub CPAN::Shell::_u_r_common ;
1714 sub _u_r_common {
1715     my($self) = shift @_;
1716     my($what) = shift @_;
1717     CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
1718     Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
1719           $what && $what =~ /^[aru]$/;
1720     my(@args) = @_;
1721     @args = '/./' unless @args;
1722     my(@result,$module,%seen,%need,$headerdone,
1723        $version_undefs,$version_zeroes);
1724     $version_undefs = $version_zeroes = 0;
1725     my $sprintf = "%s%-25s%s %9s %9s  %s\n";
1726     my @expand = $self->expand('Module',@args);
1727     my $expand = scalar @expand;
1728     if (0) { # Looks like noise to me, was very useful for debugging
1729              # for metadata cache
1730         $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
1731     }
1732   MODULE: for $module (@expand) {
1733         my $file  = $module->cpan_file;
1734         next MODULE unless defined $file; # ??
1735         $file =~ s|^./../||;
1736         my($latest) = $module->cpan_version;
1737         my($inst_file) = $module->inst_file;
1738         my($have);
1739         return if $CPAN::Signal;
1740         if ($inst_file){
1741             if ($what eq "a") {
1742                 $have = $module->inst_version;
1743             } elsif ($what eq "r") {
1744                 $have = $module->inst_version;
1745                 local($^W) = 0;
1746                 if ($have eq "undef"){
1747                     $version_undefs++;
1748                 } elsif ($have == 0){
1749                     $version_zeroes++;
1750                 }
1751                 next MODULE unless CPAN::Version->vgt($latest, $have);
1752 # to be pedantic we should probably say:
1753 #    && !($have eq "undef" && $latest ne "undef" && $latest gt "");
1754 # to catch the case where CPAN has a version 0 and we have a version undef
1755             } elsif ($what eq "u") {
1756                 next MODULE;
1757             }
1758         } else {
1759             if ($what eq "a") {
1760                 next MODULE;
1761             } elsif ($what eq "r") {
1762                 next MODULE;
1763             } elsif ($what eq "u") {
1764                 $have = "-";
1765             }
1766         }
1767         return if $CPAN::Signal; # this is sometimes lengthy
1768         $seen{$file} ||= 0;
1769         if ($what eq "a") {
1770             push @result, sprintf "%s %s\n", $module->id, $have;
1771         } elsif ($what eq "r") {
1772             push @result, $module->id;
1773             next MODULE if $seen{$file}++;
1774         } elsif ($what eq "u") {
1775             push @result, $module->id;
1776             next MODULE if $seen{$file}++;
1777             next MODULE if $file =~ /^Contact/;
1778         }
1779         unless ($headerdone++){
1780             $CPAN::Frontend->myprint("\n");
1781             $CPAN::Frontend->myprint(sprintf(
1782                                              $sprintf,
1783                                              "",
1784                                              "Package namespace",
1785                                              "",
1786                                              "installed",
1787                                              "latest",
1788                                              "in CPAN file"
1789                                             ));
1790         }
1791         my $color_on = "";
1792         my $color_off = "";
1793         # $GLOBAL_AUTOLOAD_RECURSION = 12;
1794         if (
1795             $COLOR_REGISTERED
1796             &&
1797             $CPAN::META->has_inst("Term::ANSIColor")
1798             &&
1799             $module->description
1800            ) {
1801             $color_on = Term::ANSIColor::color("green");
1802             $color_off = Term::ANSIColor::color("reset");
1803         }
1804         $CPAN::Frontend->myprint(sprintf $sprintf,
1805                                  $color_on,
1806                                  $module->id,
1807                                  $color_off,
1808                                  $have,
1809                                  $latest,
1810                                  $file);
1811         $need{$module->id}++;
1812     }
1813     unless (%need) {
1814         if ($what eq "u") {
1815             $CPAN::Frontend->myprint("No modules found for @args\n");
1816         } elsif ($what eq "r") {
1817             $CPAN::Frontend->myprint("All modules are up to date for @args\n");
1818         }
1819     }
1820     if ($what eq "r") {
1821         if ($version_zeroes) {
1822             my $s_has = $version_zeroes > 1 ? "s have" : " has";
1823             $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
1824                 qq{a version number of 0\n});
1825         }
1826         if ($version_undefs) {
1827             my $s_has = $version_undefs > 1 ? "s have" : " has";
1828             $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
1829                 qq{parseable version number\n});
1830         }
1831     }
1832     @result;
1833 }
1834
1835 #-> sub CPAN::Shell::r ;
1836 sub r {
1837     shift->_u_r_common("r",@_);
1838 }
1839
1840 #-> sub CPAN::Shell::u ;
1841 sub u {
1842     shift->_u_r_common("u",@_);
1843 }
1844
1845 #-> sub CPAN::Shell::failed ;
1846 sub failed {
1847     my($self,$only_id,$silent) = @_;
1848     my @failed;
1849   DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
1850         my $failed = "";
1851       NAY: for my $nosayer (
1852                             "writemakefile",
1853                             "signature_verify",
1854                             "make",
1855                             "make_test",
1856                             "install",
1857                             "make_clean",
1858                            ) {
1859             next unless exists $d->{$nosayer};
1860             next unless (
1861                          $d->{$nosayer}->can("failed") ?
1862                          $d->{$nosayer}->failed :
1863                          $d->{$nosayer} =~ /^NO/
1864                         );
1865             next NAY if $only_id && $only_id != (
1866                                                  $d->{$nosayer}->can("commandid")
1867                                                  ?
1868                                                  $d->{$nosayer}->commandid
1869                                                  :
1870                                                  $CPAN::CurrentCommandId
1871                                                 );
1872             $failed = $nosayer;
1873             last;
1874         }
1875         next DIST unless $failed;
1876         my $id = $d->id;
1877         $id =~ s|^./../||;
1878         #$print .= sprintf(
1879         #                  "  %-45s: %s %s\n",
1880         push @failed,
1881             (
1882              $d->{$failed}->can("failed") ?
1883              [
1884               $d->{$failed}->commandid,
1885               $id,
1886               $failed,
1887               $d->{$failed}->text,
1888              ] :
1889              [
1890               1,
1891               $id,
1892               $failed,
1893               $d->{$failed},
1894              ]
1895             );
1896     }
1897     my $scope = $only_id ? "command" : "session";
1898     if (@failed) {
1899         my $print = join "",
1900             map { sprintf "  %-45s: %s %s\n", @$_[1,2,3] }
1901                 sort { $a->[0] <=> $b->[0] } @failed;
1902         $CPAN::Frontend->myprint("Failed during this $scope:\n$print");
1903     } elsif (!$only_id || !$silent) {
1904         $CPAN::Frontend->myprint("Nothing failed in this $scope\n");
1905     }
1906 }
1907
1908 # XXX intentionally undocumented because completely bogus, unportable,
1909 # useless, etc.
1910
1911 #-> sub CPAN::Shell::status ;
1912 sub status {
1913     my($self) = @_;
1914     require Devel::Size;
1915     my $ps = FileHandle->new;
1916     open $ps, "/proc/$$/status";
1917     my $vm = 0;
1918     while (<$ps>) {
1919         next unless /VmSize:\s+(\d+)/;
1920         $vm = $1;
1921         last;
1922     }
1923     $CPAN::Frontend->mywarn(sprintf(
1924                                     "%-27s %6d\n%-27s %6d\n",
1925                                     "vm",
1926                                     $vm,
1927                                     "CPAN::META",
1928                                     Devel::Size::total_size($CPAN::META)/1024,
1929                                    ));
1930     for my $k (sort keys %$CPAN::META) {
1931         next unless substr($k,0,4) eq "read";
1932         warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
1933         for my $k2 (sort keys %{$CPAN::META->{$k}}) {
1934             warn sprintf "  %-25s %6d %6d\n",
1935                 $k2,
1936                     Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
1937                           scalar keys %{$CPAN::META->{$k}{$k2}};
1938         }
1939     }
1940 }
1941
1942 #-> sub CPAN::Shell::autobundle ;
1943 sub autobundle {
1944     my($self) = shift;
1945     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
1946     my(@bundle) = $self->_u_r_common("a",@_);
1947     my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
1948     File::Path::mkpath($todir);
1949     unless (-d $todir) {
1950         $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
1951         return;
1952     }
1953     my($y,$m,$d) =  (localtime)[5,4,3];
1954     $y+=1900;
1955     $m++;
1956     my($c) = 0;
1957     my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
1958     my($to) = File::Spec->catfile($todir,"$me.pm");
1959     while (-f $to) {
1960         $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
1961         $to = File::Spec->catfile($todir,"$me.pm");
1962     }
1963     my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
1964     $fh->print(
1965                "package Bundle::$me;\n\n",
1966                "\$VERSION = '0.01';\n\n",
1967                "1;\n\n",
1968                "__END__\n\n",
1969                "=head1 NAME\n\n",
1970                "Bundle::$me - Snapshot of installation on ",
1971                $Config::Config{'myhostname'},
1972                " on ",
1973                scalar(localtime),
1974                "\n\n=head1 SYNOPSIS\n\n",
1975                "perl -MCPAN -e 'install Bundle::$me'\n\n",
1976                "=head1 CONTENTS\n\n",
1977                join("\n", @bundle),
1978                "\n\n=head1 CONFIGURATION\n\n",
1979                Config->myconfig,
1980                "\n\n=head1 AUTHOR\n\n",
1981                "This Bundle has been generated automatically ",
1982                "by the autobundle routine in CPAN.pm.\n",
1983               );
1984     $fh->close;
1985     $CPAN::Frontend->myprint("\nWrote bundle file
1986     $to\n\n");
1987 }
1988
1989 #-> sub CPAN::Shell::expandany ;
1990 sub expandany {
1991     my($self,$s) = @_;
1992     CPAN->debug("s[$s]") if $CPAN::DEBUG;
1993     if ($s =~ m|/|) { # looks like a file
1994         $s = CPAN::Distribution->normalize($s);
1995         return $CPAN::META->instance('CPAN::Distribution',$s);
1996         # Distributions spring into existence, not expand
1997     } elsif ($s =~ m|^Bundle::|) {
1998         $self->local_bundles; # scanning so late for bundles seems
1999                               # both attractive and crumpy: always
2000                               # current state but easy to forget
2001                               # somewhere
2002         return $self->expand('Bundle',$s);
2003     } else {
2004         return $self->expand('Module',$s)
2005             if $CPAN::META->exists('CPAN::Module',$s);
2006     }
2007     return;
2008 }
2009
2010 #-> sub CPAN::Shell::expand ;
2011 sub expand {
2012     my $self = shift;
2013     my($type,@args) = @_;
2014     CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
2015     my $class = "CPAN::$type";
2016     my $methods = ['id'];
2017     for my $meth (qw(name)) {
2018         next if $] < 5.00303; # no "can"
2019         next unless $class->can($meth);
2020         push @$methods, $meth;
2021     }
2022     $self->expand_by_method($class,$methods,@args);
2023 }
2024
2025 sub expand_by_method {
2026     my $self = shift;
2027     my($class,$methods,@args) = @_;
2028     my($arg,@m);
2029     for $arg (@args) {
2030         my($regex,$command);
2031         if ($arg =~ m|^/(.*)/$|) {
2032             $regex = $1;
2033         } elsif ($arg =~ m/=/) {
2034             $command = 1;
2035         }
2036         my $obj;
2037         CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
2038                     $class,
2039                     defined $regex ? $regex : "UNDEFINED",
2040                     defined $command ? $command : "UNDEFINED",
2041                    ) if $CPAN::DEBUG;
2042         if (defined $regex) {
2043             for $obj (
2044                       $CPAN::META->all_objects($class)
2045                      ) {
2046                 unless ($obj->id){
2047                     # BUG, we got an empty object somewhere
2048                     require Data::Dumper;
2049                     CPAN->debug(sprintf(
2050                                         "Bug in CPAN: Empty id on obj[%s][%s]",
2051                                         $obj,
2052                                         Data::Dumper::Dumper($obj)
2053                                        )) if $CPAN::DEBUG;
2054                     next;
2055                 }
2056                 for my $method (@$methods) {
2057                     my $match = eval {$obj->$method() =~ /$regex/i};
2058                     if ($@) {
2059                         my($err) = $@ =~ /^(.+) at .+? line \d+\.$/;
2060                         $err ||= $@; # if we were too restrictive above
2061                         $CPAN::Frontend->mydie("$err\n");
2062                     } elsif ($match) {
2063                         push @m, $obj;
2064                         last;
2065                     }
2066                 }
2067             }
2068         } elsif ($command) {
2069             die "equal sign in command disabled (immature interface), ".
2070                 "you can set
2071  ! \$CPAN::Shell::ADVANCED_QUERY=1
2072 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
2073 that may go away anytime.\n"
2074                     unless $ADVANCED_QUERY;
2075             my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
2076             my($matchcrit) = $criterion =~ m/^~(.+)/;
2077             for my $self (
2078                           sort
2079                           {$a->id cmp $b->id}
2080                           $CPAN::META->all_objects($class)
2081                          ) {
2082                 my $lhs = $self->$method() or next; # () for 5.00503
2083                 if ($matchcrit) {
2084                     push @m, $self if $lhs =~ m/$matchcrit/;
2085                 } else {
2086                     push @m, $self if $lhs eq $criterion;
2087                 }
2088             }
2089         } else {
2090             my($xarg) = $arg;
2091             if ( $class eq 'CPAN::Bundle' ) {
2092                 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
2093             } elsif ($class eq "CPAN::Distribution") {
2094                 $xarg = CPAN::Distribution->normalize($arg);
2095             } else {
2096                 $xarg =~ s/:+/::/g;
2097             }
2098             if ($CPAN::META->exists($class,$xarg)) {
2099                 $obj = $CPAN::META->instance($class,$xarg);
2100             } elsif ($CPAN::META->exists($class,$arg)) {
2101                 $obj = $CPAN::META->instance($class,$arg);
2102             } else {
2103                 next;
2104             }
2105             push @m, $obj;
2106         }
2107     }
2108     @m = sort {$a->id cmp $b->id} @m;
2109     if ( $CPAN::DEBUG ) {
2110         my $wantarray = wantarray;
2111         my $join_m = join ",", map {$_->id} @m;
2112         $self->debug("wantarray[$wantarray]join_m[$join_m]");
2113     }
2114     return wantarray ? @m : $m[0];
2115 }
2116
2117 #-> sub CPAN::Shell::format_result ;
2118 sub format_result {
2119     my($self) = shift;
2120     my($type,@args) = @_;
2121     @args = '/./' unless @args;
2122     my(@result) = $self->expand($type,@args);
2123     my $result = @result == 1 ?
2124         $result[0]->as_string :
2125             @result == 0 ?
2126                 "No objects of type $type found for argument @args\n" :
2127                     join("",
2128                          (map {$_->as_glimpse} @result),
2129                          scalar @result, " items found\n",
2130                         );
2131     $result;
2132 }
2133
2134 #-> sub CPAN::Shell::report_fh ;
2135 {
2136     my $installation_report_fh;
2137     my $previously_noticed = 0;
2138
2139     sub report_fh {
2140         return $installation_report_fh if $installation_report_fh;
2141         if ($CPAN::META->has_inst("File::Temp")) {
2142             $installation_report_fh
2143                 = File::Temp->new(
2144                                   template => 'cpan_install_XXXX',
2145                                   suffix   => '.txt',
2146                                   unlink   => 0,
2147                                  );
2148         }
2149         unless ( $installation_report_fh ) {
2150             warn("Couldn't open installation report file; " .
2151                  "no report file will be generated."
2152                 ) unless $previously_noticed++;
2153         }
2154     }
2155 }
2156
2157
2158 # The only reason for this method is currently to have a reliable
2159 # debugging utility that reveals which output is going through which
2160 # channel. No, I don't like the colors ;-)
2161
2162 # to turn colordebugging on, write
2163 # cpan> o conf colorize_output 1
2164
2165 #-> sub CPAN::Shell::print_ornamented ;
2166 {
2167     my $print_ornamented_have_warned = 0;
2168     sub colorize_output {
2169         my $colorize_output = $CPAN::Config->{colorize_output};
2170         if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
2171             unless ($print_ornamented_have_warned++) {
2172                 # no myprint/mywarn within myprint/mywarn!
2173                 warn "Colorize_output is set to true but Term::ANSIColor is not
2174 installed. To activate colorized output, please install Term::ANSIColor.\n\n";
2175             }
2176             $colorize_output = 0;
2177         }
2178         return $colorize_output;
2179     }
2180 }
2181
2182
2183 sub print_ornamented {
2184     my($self,$what,$ornament) = @_;
2185     return unless defined $what;
2186
2187     local $| = 1; # Flush immediately
2188     if ( $CPAN::Be_Silent ) {
2189         print {report_fh()} $what;
2190         return;
2191     }
2192     my $swhat = "$what"; # stringify if it is an object
2193     if ($CPAN::Config->{term_is_latin}){
2194         # courtesy jhi:
2195         $swhat
2196             =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
2197     }
2198     if ($self->colorize_output) {
2199         if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
2200             # if you want to have this configurable, please file a bugreport
2201             $ornament = "black on_cyan";
2202         }
2203         my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
2204         if ($@) {
2205             print "Term::ANSIColor rejects color[$ornament]: $@\n
2206 Please choose a different color (Hint: try 'o conf init color.*')\n";
2207         }
2208         print $color_on,
2209             $swhat,
2210                 Term::ANSIColor::color("reset");
2211     } else {
2212         print $swhat;
2213     }
2214 }
2215
2216 # where is myprint/mywarn/Frontend/etc. documented? We need guidelines
2217 # where to use what! I think, we send everything to STDOUT and use
2218 # print for normal/good news and warn for news that need more
2219 # attention. Yes, this is our working contract for now.
2220 sub myprint {
2221     my($self,$what) = @_;
2222
2223     $self->print_ornamented($what, $CPAN::Config->{colorize_print}||'bold blue on_white');
2224 }
2225
2226 sub myexit {
2227     my($self,$what) = @_;
2228     $self->myprint($what);
2229     exit;
2230 }
2231
2232 sub mywarn {
2233     my($self,$what) = @_;
2234     $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
2235 }
2236
2237 # only to be used for shell commands
2238 sub mydie {
2239     my($self,$what) = @_;
2240     $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
2241
2242     # If it is the shell, we want that the following die to be silent,
2243     # but if it is not the shell, we would need a 'die $what'. We need
2244     # to take care that only shell commands use mydie. Is this
2245     # possible?
2246
2247     die "\n";
2248 }
2249
2250 # sub CPAN::Shell::colorable_makemaker_prompt
2251 sub colorable_makemaker_prompt {
2252     my($foo,$bar) = @_;
2253     if (CPAN::Shell->colorize_output) {
2254         my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
2255         my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
2256         print $color_on;
2257     }
2258     my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
2259     if (CPAN::Shell->colorize_output) {
2260         print Term::ANSIColor::color('reset');
2261     }
2262     return $ans;
2263 }
2264
2265 # use this only for unrecoverable errors!
2266 sub unrecoverable_error {
2267     my($self,$what) = @_;
2268     my @lines = split /\n/, $what;
2269     my $longest = 0;
2270     for my $l (@lines) {
2271         $longest = length $l if length $l > $longest;
2272     }
2273     $longest = 62 if $longest > 62;
2274     for my $l (@lines) {
2275         if ($l =~ /^\s*$/){
2276             $l = "\n";
2277             next;
2278         }
2279         $l = "==> $l";
2280         if (length $l < 66) {
2281             $l = pack "A66 A*", $l, "<==";
2282         }
2283         $l .= "\n";
2284     }
2285     unshift @lines, "\n";
2286     $self->mydie(join "", @lines);
2287 }
2288
2289 sub mysleep {
2290     my($self, $sleep) = @_;
2291     sleep $sleep;
2292 }
2293
2294 sub setup_output {
2295     return if -t STDOUT;
2296     my $odef = select STDERR;
2297     $| = 1;
2298     select STDOUT;
2299     $| = 1;
2300     select $odef;
2301 }
2302
2303 #-> sub CPAN::Shell::rematein ;
2304 # RE-adme||MA-ke||TE-st||IN-stall
2305 sub rematein {
2306     my $self = shift;
2307     my($meth,@some) = @_;
2308     my @pragma;
2309     while($meth =~ /^(force|notest)$/) {
2310         push @pragma, $meth;
2311         $meth = shift @some or
2312             $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
2313                                    "cannot continue");
2314     }
2315     setup_output();
2316     CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
2317
2318     # Here is the place to set "test_count" on all involved parties to
2319     # 0. We then can pass this counter on to the involved
2320     # distributions and those can refuse to test if test_count > X. In
2321     # the first stab at it we could use a 1 for "X".
2322
2323     # But when do I reset the distributions to start with 0 again?
2324     # Jost suggested to have a random or cycling interaction ID that
2325     # we pass through. But the ID is something that is just left lying
2326     # around in addition to the counter, so I'd prefer to set the
2327     # counter to 0 now, and repeat at the end of the loop. But what
2328     # about dependencies? They appear later and are not reset, they
2329     # enter the queue but not its copy. How do they get a sensible
2330     # test_count?
2331
2332     # construct the queue
2333     my($s,@s,@qcopy);
2334   STHING: foreach $s (@some) {
2335         my $obj;
2336         if (ref $s) {
2337             CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
2338             $obj = $s;
2339         } elsif ($s =~ m|^/|) { # looks like a regexp
2340             $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
2341                                     "not supported\n");
2342             $CPAN::Frontend->mysleep(2);
2343             next;
2344         } elsif ($meth eq "ls") {
2345             $self->globls($s,\@pragma);
2346             next STHING;
2347         } else {
2348             CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
2349             $obj = CPAN::Shell->expandany($s);
2350         }
2351         if (ref $obj) {
2352             $obj->color_cmd_tmps(0,1);
2353             CPAN::Queue->new(qmod => $obj->id, reqtype => "c");
2354             push @qcopy, $obj;
2355         } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
2356             $obj = $CPAN::META->instance('CPAN::Author',uc($s));
2357             if ($meth =~ /^(dump|ls)$/) {
2358                 $obj->$meth();
2359             } else {
2360                 $CPAN::Frontend->mywarn(
2361                                         join "",
2362                                         "Don't be silly, you can't $meth ",
2363                                         $obj->fullname,
2364                                         " ;-)\n"
2365                                        );
2366                 $CPAN::Frontend->mysleep(2);
2367             }
2368         } elsif ($meth eq "dump") {
2369             CPAN::InfoObj->dump($s);
2370         } else {
2371             $CPAN::Frontend
2372                 ->mywarn(qq{Warning: Cannot $meth $s, }.
2373                           qq{don't know what it is.
2374 Try the command
2375
2376     i /$s/
2377
2378 to find objects with matching identifiers.
2379 });
2380             $CPAN::Frontend->mysleep(2);
2381         }
2382     }
2383
2384     # queuerunner (please be warned: when I started to change the
2385     # queue to hold objects instead of names, I made one or two
2386     # mistakes and never found which. I reverted back instead)
2387     while (my $q = CPAN::Queue->first) {
2388         my $obj;
2389         my $s = $q->as_string;
2390         my $reqtype = $q->reqtype || "";
2391         $obj = CPAN::Shell->expandany($s);
2392         $obj->{reqtype} ||= "";
2393         CPAN->debug("obj-reqtype[$obj->{reqtype}]".
2394                     "q-reqtype[$reqtype]") if $CPAN::DEBUG;
2395         if ($obj->{reqtype}) {
2396             if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
2397                 $obj->{reqtype} = $reqtype;
2398                 if (
2399                     exists $obj->{install}
2400                     &&
2401                     (
2402                      $obj->{install}->can("failed") ?
2403                      $obj->{install}->failed :
2404                      $obj->{install} =~ /^NO/
2405                     )
2406                    ) {
2407                     delete $obj->{install};
2408                     $CPAN::Frontend->mywarn
2409                         ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
2410                 }
2411             }
2412         } else {
2413             $obj->{reqtype} = $reqtype;
2414         }
2415
2416         for my $pragma (@pragma) {
2417             if ($pragma
2418                 &&
2419                 ($] < 5.00303 || $obj->can($pragma))){
2420                 ### compatibility with 5.003
2421                 $obj->$pragma($meth); # the pragma "force" in
2422                                       # "CPAN::Distribution" must know
2423                                       # what we are intending
2424             }
2425         }
2426         if ($]>=5.00303 && $obj->can('called_for')) {
2427             $obj->called_for($s);
2428         }
2429         CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
2430                     qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
2431
2432         if ($obj->$meth()){
2433             CPAN::Queue->delete($s);
2434         } else {
2435             CPAN->debug("failed");
2436         }
2437
2438         $obj->undelay;
2439         CPAN::Queue->delete_first($s);
2440     }
2441     for my $obj (@qcopy) {
2442         $obj->color_cmd_tmps(0,0);
2443         delete $obj->{incommandcolor};
2444     }
2445 }
2446
2447 #-> sub CPAN::Shell::recent ;
2448 sub recent {
2449   my($self) = @_;
2450
2451   CPAN::Distribution::_display_url( $self, $CPAN::Defaultrecent );
2452   return;
2453 }
2454
2455 {
2456     # set up the dispatching methods
2457     no strict "refs";
2458     for my $command (qw(
2459                         clean
2460                         cvs_import
2461                         dump
2462                         force
2463                         get
2464                         install
2465                         look
2466                         ls
2467                         make
2468                         notest
2469                         perldoc
2470                         readme
2471                         test
2472                        )) {
2473         *$command = sub { shift->rematein($command, @_); };
2474     }
2475 }
2476
2477 package CPAN::LWP::UserAgent;
2478 use strict;
2479
2480 sub config {
2481     return if $SETUPDONE;
2482     if ($CPAN::META->has_usable('LWP::UserAgent')) {
2483         require LWP::UserAgent;
2484         @ISA = qw(Exporter LWP::UserAgent);
2485         $SETUPDONE++;
2486     } else {
2487         $CPAN::Frontend->mywarn("  LWP::UserAgent not available\n");
2488     }
2489 }
2490
2491 sub get_basic_credentials {
2492     my($self, $realm, $uri, $proxy) = @_;
2493     if ($USER && $PASSWD) {
2494         return ($USER, $PASSWD);
2495     }
2496     if ( $proxy ) {
2497         ($USER,$PASSWD) = $self->get_proxy_credentials();
2498     } else {
2499         ($USER,$PASSWD) = $self->get_non_proxy_credentials();
2500     }
2501     return($USER,$PASSWD);
2502 }
2503
2504 sub get_proxy_credentials {
2505     my $self = shift;
2506     my ($user, $password);
2507     if ( defined $CPAN::Config->{proxy_user} &&
2508          defined $CPAN::Config->{proxy_pass}) {
2509         $user = $CPAN::Config->{proxy_user};
2510         $password = $CPAN::Config->{proxy_pass};
2511         return ($user, $password);
2512     }
2513     my $username_prompt = "\nProxy authentication needed!
2514  (Note: to permanently configure username and password run
2515    o conf proxy_user your_username
2516    o conf proxy_pass your_password
2517      )\nUsername:";
2518     ($user, $password) =
2519         _get_username_and_password_from_user($username_prompt);
2520     return ($user,$password);
2521 }
2522
2523 sub get_non_proxy_credentials {
2524     my $self = shift;
2525     my ($user,$password);
2526     if ( defined $CPAN::Config->{username} &&
2527          defined $CPAN::Config->{password}) {
2528         $user = $CPAN::Config->{username};
2529         $password = $CPAN::Config->{password};
2530         return ($user, $password);
2531     }
2532     my $username_prompt = "\nAuthentication needed!
2533      (Note: to permanently configure username and password run
2534        o conf username your_username
2535        o conf password your_password
2536      )\nUsername:";
2537
2538     ($user, $password) =
2539         _get_username_and_password_from_user($username_prompt);
2540     return ($user,$password);
2541 }
2542
2543 sub _get_username_and_password_from_user {
2544     my $self = shift;
2545     my $username_message = shift;
2546     my ($username,$password);
2547
2548     ExtUtils::MakeMaker->import(qw(prompt));
2549     $username = prompt($username_message);
2550         if ($CPAN::META->has_inst("Term::ReadKey")) {
2551             Term::ReadKey::ReadMode("noecho");
2552         }
2553     else {
2554         $CPAN::Frontend->mywarn(
2555             "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"
2556         );
2557     }
2558     $password = prompt("Password:");
2559
2560         if ($CPAN::META->has_inst("Term::ReadKey")) {
2561             Term::ReadKey::ReadMode("restore");
2562         }
2563         $CPAN::Frontend->myprint("\n\n");
2564     return ($username,$password);
2565 }
2566
2567 # mirror(): Its purpose is to deal with proxy authentication. When we
2568 # call SUPER::mirror, we relly call the mirror method in
2569 # LWP::UserAgent. LWP::UserAgent will then call
2570 # $self->get_basic_credentials or some equivalent and this will be
2571 # $self->dispatched to our own get_basic_credentials method.
2572
2573 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
2574
2575 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
2576 # although we have gone through our get_basic_credentials, the proxy
2577 # server refuses to connect. This could be a case where the username or
2578 # password has changed in the meantime, so I'm trying once again without
2579 # $USER and $PASSWD to give the get_basic_credentials routine another
2580 # chance to set $USER and $PASSWD.
2581
2582 # mirror(): Its purpose is to deal with proxy authentication. When we
2583 # call SUPER::mirror, we relly call the mirror method in
2584 # LWP::UserAgent. LWP::UserAgent will then call
2585 # $self->get_basic_credentials or some equivalent and this will be
2586 # $self->dispatched to our own get_basic_credentials method.
2587
2588 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
2589
2590 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
2591 # although we have gone through our get_basic_credentials, the proxy
2592 # server refuses to connect. This could be a case where the username or
2593 # password has changed in the meantime, so I'm trying once again without
2594 # $USER and $PASSWD to give the get_basic_credentials routine another
2595 # chance to set $USER and $PASSWD.
2596
2597 sub mirror {
2598     my($self,$url,$aslocal) = @_;
2599     my $result = $self->SUPER::mirror($url,$aslocal);
2600     if ($result->code == 407) {
2601         undef $USER;
2602         undef $PASSWD;
2603         $result = $self->SUPER::mirror($url,$aslocal);
2604     }
2605     $result;
2606 }
2607
2608 package CPAN::FTP;
2609 use strict;
2610
2611 #-> sub CPAN::FTP::ftp_get ;
2612 sub ftp_get {
2613     my($class,$host,$dir,$file,$target) = @_;
2614     $class->debug(
2615                   qq[Going to fetch file [$file] from dir [$dir]
2616         on host [$host] as local [$target]\n]
2617                  ) if $CPAN::DEBUG;
2618     my $ftp = Net::FTP->new($host);
2619     unless ($ftp) {
2620         $CPAN::Frontend->mywarn("  Could not connect to host '$host' with Net::FTP\n");
2621         return;
2622     }
2623     return 0 unless defined $ftp;
2624     $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
2625     $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
2626     unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
2627         my $msg = $ftp->message;
2628         $CPAN::Frontend->mywarn("  Couldn't login on $host: $msg");
2629         return;
2630     }
2631     unless ( $ftp->cwd($dir) ){
2632         my $msg = $ftp->message;
2633         $CPAN::Frontend->mywarn("  Couldn't cwd $dir: $msg");
2634         return;
2635     }
2636     $ftp->binary;
2637     $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
2638     unless ( $ftp->get($file,$target) ){
2639         my $msg = $ftp->message;
2640         $CPAN::Frontend->mywarn("  Couldn't fetch $file from $host: $msg");
2641         return;
2642     }
2643     $ftp->quit; # it's ok if this fails
2644     return 1;
2645 }
2646
2647 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
2648
2649  # > *** /install/perl/live/lib/CPAN.pm-        Wed Sep 24 13:08:48 1997
2650  # > --- /tmp/cp        Wed Sep 24 13:26:40 1997
2651  # > ***************
2652  # > *** 1562,1567 ****
2653  # > --- 1562,1580 ----
2654  # >       return 1 if substr($url,0,4) eq "file";
2655  # >       return 1 unless $url =~ m|://([^/]+)|;
2656  # >       my $host = $1;
2657  # > +     my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
2658  # > +     if ($proxy) {
2659  # > +         $proxy =~ m|://([^/:]+)|;
2660  # > +         $proxy = $1;
2661  # > +         my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
2662  # > +         if ($noproxy) {
2663  # > +             if ($host !~ /$noproxy$/) {
2664  # > +                 $host = $proxy;
2665  # > +             }
2666  # > +         } else {
2667  # > +             $host = $proxy;
2668  # > +         }
2669  # > +     }
2670  # >       require Net::Ping;
2671  # >       return 1 unless $Net::Ping::VERSION >= 2;
2672  # >       my $p;
2673
2674
2675 #-> sub CPAN::FTP::localize ;
2676 sub localize {
2677     my($self,$file,$aslocal,$force) = @_;
2678     $force ||= 0;
2679     Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
2680         unless defined $aslocal;
2681     $self->debug("file[$file] aslocal[$aslocal] force[$force]")
2682         if $CPAN::DEBUG;
2683
2684     if ($^O eq 'MacOS') {
2685         # Comment by AK on 2000-09-03: Uniq short filenames would be
2686         # available in CHECKSUMS file
2687         my($name, $path) = File::Basename::fileparse($aslocal, '');
2688         if (length($name) > 31) {
2689             $name =~ s/(
2690                         \.(
2691                            readme(\.(gz|Z))? |
2692                            (tar\.)?(gz|Z) |
2693                            tgz |
2694                            zip |
2695                            pm\.(gz|Z)
2696                           )
2697                        )$//x;
2698             my $suf = $1;
2699             my $size = 31 - length($suf);
2700             while (length($name) > $size) {
2701                 chop $name;
2702             }
2703             $name .= $suf;
2704             $aslocal = File::Spec->catfile($path, $name);
2705         }
2706     }
2707
2708     if (-f $aslocal && -r _ && !($force & 1)){
2709         my $size;
2710         if ($size = -s $aslocal) {
2711             $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
2712             return $aslocal;
2713         } else {
2714             # empty file from a previous unsuccessful attempt to download it
2715             unlink $aslocal or
2716                 $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
2717                                        "could not remove.");
2718         }
2719     }
2720     my($restore) = 0;
2721     if (-f $aslocal){
2722         rename $aslocal, "$aslocal.bak";
2723         $restore++;
2724     }
2725
2726     my($aslocal_dir) = File::Basename::dirname($aslocal);
2727     File::Path::mkpath($aslocal_dir);
2728     $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
2729         qq{directory "$aslocal_dir".
2730     I\'ll continue, but if you encounter problems, they may be due
2731     to insufficient permissions.\n}) unless -w $aslocal_dir;
2732
2733     # Inheritance is not easier to manage than a few if/else branches
2734     if ($CPAN::META->has_usable('LWP::UserAgent')) {
2735         unless ($Ua) {
2736             CPAN::LWP::UserAgent->config;
2737             eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
2738             if ($@) {
2739                 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
2740                     if $CPAN::DEBUG;
2741             } else {
2742                 my($var);
2743                 $Ua->proxy('ftp',  $var)
2744                     if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
2745                 $Ua->proxy('http', $var)
2746                     if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
2747
2748
2749 # >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
2750 #
2751 #  > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
2752 #  > use ones that require basic autorization.
2753 #
2754 #  > Example of when I use it manually in my own stuff:
2755 #
2756 #  > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
2757 #  > $req->proxy_authorization_basic("username","password");
2758 #  > $res = $ua->request($req);
2759 #
2760
2761                 $Ua->no_proxy($var)
2762                     if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
2763             }
2764         }
2765     }
2766     for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
2767         $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
2768     }
2769
2770     # Try the list of urls for each single object. We keep a record
2771     # where we did get a file from
2772     my(@reordered,$last);
2773     $CPAN::Config->{urllist} ||= [];
2774     unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
2775         $CPAN::Frontend->mywarn("Malformed urllist; ignoring.  Configuration file corrupt?\n");
2776         $CPAN::Config->{urllist} = [];
2777     }
2778     $last = $#{$CPAN::Config->{urllist}};
2779     if ($force & 2) { # local cpans probably out of date, don't reorder
2780         @reordered = (0..$last);
2781     } else {
2782         @reordered =
2783             sort {
2784                 (substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
2785                     <=>
2786                 (substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
2787                     or
2788                 defined($ThesiteURL)
2789                     and
2790                 ($CPAN::Config->{urllist}[$b] eq $ThesiteURL)
2791                     <=>
2792                 ($CPAN::Config->{urllist}[$a] eq $ThesiteURL)
2793             } 0..$last;
2794     }
2795     my(@levels);
2796     $Themethod ||= "";
2797     $self->debug("Themethod[$Themethod]") if $CPAN::DEBUG;
2798     if ($Themethod) {
2799         @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
2800     } else {
2801         @levels = qw/easy hard hardest/;
2802     }
2803     @levels = qw/easy/ if $^O eq 'MacOS';
2804     my($levelno);
2805     local $ENV{FTP_PASSIVE} =
2806         exists $CPAN::Config->{ftp_passive} ?
2807         $CPAN::Config->{ftp_passive} : 1;
2808     for $levelno (0..$#levels) {
2809         my $level = $levels[$levelno];
2810         my $method = "host$level";
2811         my @host_seq = $level eq "easy" ?
2812             @reordered : 0..$last;  # reordered has CDROM up front
2813         my @urllist = map { $CPAN::Config->{urllist}[$_] } @host_seq;
2814         for my $u (@urllist) {
2815             if ($u->can("text")) {
2816                 $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
2817             } else {
2818                 $u .= "/" unless substr($u,-1) eq "/";
2819                 $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
2820             }
2821         }
2822         for my $u (@CPAN::Defaultsites) {
2823             push @urllist, $u unless grep { $_ eq $u } @urllist;
2824         }
2825         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
2826         my $ret = $self->$method(\@urllist,$file,$aslocal);
2827         if ($ret) {
2828           $Themethod = $level;
2829           my $now = time;
2830           # utime $now, $now, $aslocal; # too bad, if we do that, we
2831                                       # might alter a local mirror
2832           $self->debug("level[$level]") if $CPAN::DEBUG;
2833           return $ret;
2834         } else {
2835           unlink $aslocal;
2836           last if $CPAN::Signal; # need to cleanup
2837         }
2838     }
2839     unless ($CPAN::Signal) {
2840         my(@mess);
2841         local $" = " ";
2842         if (@{$CPAN::Config->{urllist}}) {
2843             push @mess,
2844                 qq{Please check, if the URLs I found in your configuration file \(}.
2845                     join(", ", @{$CPAN::Config->{urllist}}).
2846                         qq{\) are valid.};
2847         } else {
2848             push @mess, qq{Your urllist is empty!};
2849         }
2850         push @mess, qq{The urllist can be edited.},
2851             qq{E.g. with 'o conf urllist push ftp://myurl/'};
2852         $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
2853         $CPAN::Frontend->mywarn("Could not fetch $file\n");
2854         $CPAN::Frontend->mysleep(2);
2855     }
2856     if ($restore) {
2857         rename "$aslocal.bak", $aslocal;
2858         $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
2859                                  $self->ls($aslocal));
2860         return $aslocal;
2861     }
2862     return;
2863 }
2864
2865 # package CPAN::FTP;
2866 sub hosteasy {
2867     my($self,$host_seq,$file,$aslocal) = @_;
2868     my($ro_url);
2869   HOSTEASY: for $ro_url (@$host_seq) {
2870         my $url .= "$ro_url$file";
2871         $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
2872         if ($url =~ /^file:/) {
2873             my $l;
2874             if ($CPAN::META->has_inst('URI::URL')) {
2875                 my $u =  URI::URL->new($url);
2876                 $l = $u->path;
2877             } else { # works only on Unix, is poorly constructed, but
2878                 # hopefully better than nothing.
2879                 # RFC 1738 says fileurl BNF is
2880                 # fileurl = "file://" [ host | "localhost" ] "/" fpath
2881                 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
2882                 # the code
2883                 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
2884                 $l =~ s|^file:||;                   # assume they
2885                                                     # meant
2886                                                     # file://localhost
2887                 $l =~ s|^/||s
2888                     if ! -f $l && $l =~ m|^/\w:|;   # e.g. /P:
2889             }
2890             $self->debug("local file[$l]") if $CPAN::DEBUG;
2891             if ( -f $l && -r _) {
2892                 $ThesiteURL = $ro_url;
2893                 return $l;
2894             }
2895             if ($l =~ /(.+)\.gz$/) {
2896                 my $ungz = $1;
2897                 if ( -f $ungz && -r _) {
2898                     $ThesiteURL = $ro_url;
2899                     return $ungz;
2900                 }
2901             }
2902             # Maybe mirror has compressed it?
2903             if (-f "$l.gz") {
2904                 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
2905                 CPAN::Tarzip->new("$l.gz")->gunzip($aslocal);
2906                 if ( -f $aslocal) {
2907                     $ThesiteURL = $ro_url;
2908                     return $aslocal;
2909                 }
2910             }
2911         }
2912         if ($CPAN::META->has_usable('LWP')) {
2913             $CPAN::Frontend->myprint("Fetching with LWP:
2914   $url
2915 ");
2916             unless ($Ua) {
2917                 CPAN::LWP::UserAgent->config;
2918                 eval { $Ua = CPAN::LWP::UserAgent->new; };
2919                 if ($@) {
2920                     $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
2921                 }
2922             }
2923             my $res = $Ua->mirror($url, $aslocal);
2924             if ($res->is_success) {
2925                 $ThesiteURL = $ro_url;
2926                 my $now = time;
2927                 utime $now, $now, $aslocal; # download time is more
2928                                             # important than upload
2929                                             # time
2930                 return $aslocal;
2931             } elsif ($url !~ /\.gz(?!\n)\Z/) {
2932                 my $gzurl = "$url.gz";
2933                 $CPAN::Frontend->myprint("Fetching with LWP:
2934   $gzurl
2935 ");
2936                 $res = $Ua->mirror($gzurl, "$aslocal.gz");
2937                 if ($res->is_success &&
2938                     CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)
2939                    ) {
2940                     $ThesiteURL = $ro_url;
2941                     return $aslocal;
2942                 }
2943             } else {
2944                 $CPAN::Frontend->myprint(sprintf(
2945                                                  "LWP failed with code[%s] message[%s]\n",
2946                                                  $res->code,
2947                                                  $res->message,
2948                                                 ));
2949                 # Alan Burlison informed me that in firewall environments
2950                 # Net::FTP can still succeed where LWP fails. So we do not
2951                 # skip Net::FTP anymore when LWP is available.
2952             }
2953         } elsif (
2954                  $ro_url->can("text")
2955                  and
2956                  $ro_url->{FROM} eq "USER"
2957                 ){
2958             my $ret = $self->hosthard([$ro_url],$file,$aslocal);
2959             return $ret if $ret;
2960         } else {
2961             $CPAN::Frontend->mywarn("  LWP not available\n");
2962         }
2963         return if $CPAN::Signal;
2964         if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2965             # that's the nice and easy way thanks to Graham
2966             my($host,$dir,$getfile) = ($1,$2,$3);
2967             if ($CPAN::META->has_usable('Net::FTP')) {
2968                 $dir =~ s|/+|/|g;
2969                 $CPAN::Frontend->myprint("Fetching with Net::FTP:
2970   $url
2971 ");
2972                 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
2973                              "aslocal[$aslocal]") if $CPAN::DEBUG;
2974                 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
2975                     $ThesiteURL = $ro_url;
2976                     return $aslocal;
2977                 }
2978                 if ($aslocal !~ /\.gz(?!\n)\Z/) {
2979                     my $gz = "$aslocal.gz";
2980                     $CPAN::Frontend->myprint("Fetching with Net::FTP
2981   $url.gz
2982 ");
2983                     if (CPAN::FTP->ftp_get($host,
2984                                            $dir,
2985                                            "$getfile.gz",
2986                                            $gz) &&
2987                         CPAN::Tarzip->new($gz)->gunzip($aslocal)
2988                        ){
2989                         $ThesiteURL = $ro_url;
2990                         return $aslocal;
2991                     }
2992                 }
2993                 # next HOSTEASY;
2994             }
2995         }
2996         return if $CPAN::Signal;
2997     }
2998 }
2999
3000 # package CPAN::FTP;
3001 sub hosthard {
3002   my($self,$host_seq,$file,$aslocal) = @_;
3003
3004   # Came back if Net::FTP couldn't establish connection (or
3005   # failed otherwise) Maybe they are behind a firewall, but they
3006   # gave us a socksified (or other) ftp program...
3007
3008   my($ro_url);
3009   my($devnull) = $CPAN::Config->{devnull} || "";
3010   # < /dev/null ";
3011   my($aslocal_dir) = File::Basename::dirname($aslocal);
3012   File::Path::mkpath($aslocal_dir);
3013   HOSTHARD: for $ro_url (@$host_seq) {
3014         my $url = "$ro_url$file";
3015         my($proto,$host,$dir,$getfile);
3016
3017         # Courtesy Mark Conty mark_conty@cargill.com change from
3018         # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3019         # to
3020         if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
3021           # proto not yet used
3022           ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
3023         } else {
3024           next HOSTHARD; # who said, we could ftp anything except ftp?
3025         }
3026         next HOSTHARD if $proto eq "file"; # file URLs would have had
3027                                            # success above. Likely a bogus URL
3028
3029         $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
3030
3031         # Try the most capable first and leave ncftp* for last as it only
3032         # does FTP.
3033       DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
3034           my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
3035           next unless defined $funkyftp;
3036           next if $funkyftp =~ /^\s*$/;
3037
3038           my($asl_ungz, $asl_gz);
3039           ($asl_ungz = $aslocal) =~ s/\.gz//;
3040           $asl_gz = "$asl_ungz.gz";
3041
3042           my($src_switch) = "";
3043           my($chdir) = "";
3044           my($stdout_redir) = " > $asl_ungz";
3045           if ($f eq "lynx"){
3046             $src_switch = " -source";
3047           } elsif ($f eq "ncftp"){
3048             $src_switch = " -c";
3049           } elsif ($f eq "wget"){
3050             $src_switch = " -O $asl_ungz";
3051             $stdout_redir = "";
3052           } elsif ($f eq 'curl'){
3053             $src_switch = ' -L -f -s -S --netrc-optional';
3054           }
3055
3056           if ($f eq "ncftpget"){
3057             $chdir = "cd $aslocal_dir && ";
3058             $stdout_redir = "";
3059           }
3060           $CPAN::Frontend->myprint(
3061                                    qq[
3062 Trying with "$funkyftp$src_switch" to get
3063     $url
3064 ]);
3065           my($system) =
3066               "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
3067           $self->debug("system[$system]") if $CPAN::DEBUG;
3068           my($wstatus) = system($system);
3069           if ($f eq "lynx") {
3070               # lynx returns 0 when it fails somewhere
3071               if (-s $asl_ungz) {
3072                   my $content = do { local *FH; open FH, $asl_ungz or die; local $/; <FH> };
3073                   if ($content =~ /^<.*<title>[45]/si) {
3074                       $CPAN::Frontend->mywarn(qq{
3075 No success, the file that lynx has has downloaded looks like an error message:
3076 $content
3077 });
3078                       $CPAN::Frontend->mysleep(1);
3079                       next DLPRG;
3080                   }
3081               } else {
3082                   $CPAN::Frontend->myprint(qq{
3083 No success, the file that lynx has has downloaded is an empty file.
3084 });
3085                   next DLPRG;
3086               }
3087           }
3088           if ($wstatus == 0) {
3089             if (-s $aslocal) {
3090               # Looks good
3091             } elsif ($asl_ungz ne $aslocal) {
3092               # test gzip integrity
3093               if (CPAN::Tarzip->new($asl_ungz)->gtest) {
3094                   # e.g. foo.tar is gzipped --> foo.tar.gz
3095                   rename $asl_ungz, $aslocal;
3096               } else {
3097                   CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz);
3098               }
3099             }
3100             $ThesiteURL = $ro_url;
3101             return $aslocal;
3102           } elsif ($url !~ /\.gz(?!\n)\Z/) {
3103             unlink $asl_ungz if
3104                 -f $asl_ungz && -s _ == 0;
3105             my $gz = "$aslocal.gz";
3106             my $gzurl = "$url.gz";
3107             $CPAN::Frontend->myprint(
3108                                      qq[
3109 Trying with "$funkyftp$src_switch" to get
3110   $url.gz
3111 ]);
3112             my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
3113             $self->debug("system[$system]") if $CPAN::DEBUG;
3114             my($wstatus);
3115             if (($wstatus = system($system)) == 0
3116                 &&
3117                 -s $asl_gz
3118                ) {
3119               # test gzip integrity
3120               my $ct = CPAN::Tarzip->new($asl_gz);
3121               if ($ct->gtest) {
3122                   $ct->gunzip($aslocal);
3123               } else {
3124                   # somebody uncompressed file for us?
3125                   rename $asl_ungz, $aslocal;
3126               }
3127               $ThesiteURL = $ro_url;
3128               return $aslocal;
3129             } else {
3130               unlink $asl_gz if -f $asl_gz;
3131             }
3132           } else {
3133             my $estatus = $wstatus >> 8;
3134             my $size = -f $aslocal ?
3135                 ", left\n$aslocal with size ".-s _ :
3136                     "\nWarning: expected file [$aslocal] doesn't exist";
3137             $CPAN::Frontend->myprint(qq{
3138 System call "$system"
3139 returned status $estatus (wstat $wstatus)$size
3140 });
3141           }
3142           return if $CPAN::Signal;
3143         } # transfer programs
3144     } # host
3145 }
3146
3147 # package CPAN::FTP;
3148 sub hosthardest {
3149     my($self,$host_seq,$file,$aslocal) = @_;
3150
3151     my($ro_url);
3152     my($aslocal_dir) = File::Basename::dirname($aslocal);
3153     File::Path::mkpath($aslocal_dir);
3154     my $ftpbin = $CPAN::Config->{ftp};
3155     unless (length $ftpbin && MM->maybe_command($ftpbin)) {
3156         $CPAN::Frontend->myprint("No external ftp command available\n\n");
3157         return;
3158     }
3159     $CPAN::Frontend->mywarn(qq{
3160 As a last ressort we now switch to the external ftp command '$ftpbin'
3161 to get '$aslocal'.
3162
3163 Doing so often leads to problems that are hard to diagnose.
3164
3165 If you're victim of such problems, please consider unsetting the ftp
3166 config variable with
3167
3168     o conf ftp ""
3169     o conf commit
3170
3171 });
3172     $CPAN::Frontend->mysleep(2);
3173   HOSTHARDEST: for $ro_url (@$host_seq) {
3174         my $url = "$ro_url$file";
3175         $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
3176         unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3177             next;
3178         }
3179         my($host,$dir,$getfile) = ($1,$2,$3);
3180         my $timestamp = 0;
3181         my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
3182            $ctime,$blksize,$blocks) = stat($aslocal);
3183         $timestamp = $mtime ||= 0;
3184         my($netrc) = CPAN::FTP::netrc->new;
3185         my($netrcfile) = $netrc->netrc;
3186         my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
3187         my $targetfile = File::Basename::basename($aslocal);
3188         my(@dialog);
3189         push(
3190              @dialog,
3191              "lcd $aslocal_dir",
3192              "cd /",
3193              map("cd $_", split /\//, $dir), # RFC 1738
3194              "bin",
3195              "get $getfile $targetfile",
3196              "quit"
3197             );
3198         if (! $netrcfile) {
3199             CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
3200         } elsif ($netrc->hasdefault || $netrc->contains($host)) {
3201             CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
3202                                 $netrc->hasdefault,
3203                                 $netrc->contains($host))) if $CPAN::DEBUG;
3204             if ($netrc->protected) {
3205                 my $dialog = join "", map { "    $_\n" } @dialog;
3206                 my $netrc_explain;
3207                 if ($netrc->contains($host)) {
3208                     $netrc_explain = "Relying that your .netrc entry for '$host' ".
3209                         "manages the login";
3210                 } else {
3211                     $netrc_explain = "Relying that your default .netrc entry ".
3212                         "manages the login";
3213                 }
3214                 $CPAN::Frontend->myprint(qq{
3215   Trying with external ftp to get
3216     $url
3217   $netrc_explain
3218   Going to send the dialog
3219 $dialog
3220 }
3221                      );
3222                 $self->talk_ftp("$ftpbin$verbose $host",
3223                                 @dialog);
3224                 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
3225                  $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
3226                 $mtime ||= 0;
3227                 if ($mtime > $timestamp) {
3228                     $CPAN::Frontend->myprint("GOT $aslocal\n");
3229                     $ThesiteURL = $ro_url;
3230                     return $aslocal;
3231                 } else {
3232                     $CPAN::Frontend->myprint("Hmm... Still failed!\n");
3233                 }
3234                 return if $CPAN::Signal;
3235             } else {
3236                 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
3237                                         qq{correctly protected.\n});
3238             }
3239         } else {
3240             $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
3241   nor does it have a default entry\n");
3242         }
3243
3244         # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
3245         # then and login manually to host, using e-mail as
3246         # password.
3247         $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
3248         unshift(
3249                 @dialog,
3250                 "open $host",
3251                 "user anonymous $Config::Config{'cf_email'}"
3252                );
3253         my $dialog = join "", map { "    $_\n" } @dialog;
3254         $CPAN::Frontend->myprint(qq{
3255   Trying with external ftp to get
3256     $url
3257   Going to send the dialog
3258 $dialog
3259 }
3260                      );
3261         $self->talk_ftp("$ftpbin$verbose -n", @dialog);
3262         ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
3263          $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
3264         $mtime ||= 0;
3265         if ($mtime > $timestamp) {
3266             $CPAN::Frontend->myprint("GOT $aslocal\n");
3267             $ThesiteURL = $ro_url;
3268             return $aslocal;
3269         } else {
3270             $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
3271         }
3272         return if $CPAN::Signal;
3273         $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
3274         $CPAN::Frontend->mysleep(2);
3275     } # host
3276 }
3277
3278 # package CPAN::FTP;
3279 sub talk_ftp {
3280     my($self,$command,@dialog) = @_;
3281     my $fh = FileHandle->new;
3282     $fh->open("|$command") or die "Couldn't open ftp: $!";
3283     foreach (@dialog) { $fh->print("$_\n") }
3284     $fh->close;         # Wait for process to complete
3285     my $wstatus = $?;
3286     my $estatus = $wstatus >> 8;
3287     $CPAN::Frontend->myprint(qq{
3288 Subprocess "|$command"
3289   returned status $estatus (wstat $wstatus)
3290 }) if $wstatus;
3291 }
3292
3293 # find2perl needs modularization, too, all the following is stolen
3294 # from there
3295 # CPAN::FTP::ls
3296 sub ls {
3297     my($self,$name) = @_;
3298     my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
3299      $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
3300
3301     my($perms,%user,%group);
3302     my $pname = $name;
3303
3304     if ($blocks) {
3305         $blocks = int(($blocks + 1) / 2);
3306     }
3307     else {
3308         $blocks = int(($sizemm + 1023) / 1024);
3309     }
3310
3311     if    (-f _) { $perms = '-'; }
3312     elsif (-d _) { $perms = 'd'; }
3313     elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
3314     elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
3315     elsif (-p _) { $perms = 'p'; }
3316     elsif (-S _) { $perms = 's'; }
3317     else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
3318
3319     my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
3320     my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
3321     my $tmpmode = $mode;
3322     my $tmp = $rwx[$tmpmode & 7];
3323     $tmpmode >>= 3;
3324     $tmp = $rwx[$tmpmode & 7] . $tmp;
3325     $tmpmode >>= 3;
3326     $tmp = $rwx[$tmpmode & 7] . $tmp;
3327     substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
3328     substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
3329     substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
3330     $perms .= $tmp;
3331
3332     my $user = $user{$uid} || $uid;   # too lazy to implement lookup
3333     my $group = $group{$gid} || $gid;
3334
3335     my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
3336     my($timeyear);
3337     my($moname) = $moname[$mon];
3338     if (-M _ > 365.25 / 2) {
3339         $timeyear = $year + 1900;
3340     }
3341     else {
3342         $timeyear = sprintf("%02d:%02d", $hour, $min);
3343     }
3344
3345     sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
3346             $ino,
3347                  $blocks,
3348                       $perms,
3349                             $nlink,
3350                                 $user,
3351                                      $group,
3352                                           $sizemm,
3353                                               $moname,
3354                                                  $mday,
3355                                                      $timeyear,
3356                                                          $pname;
3357 }
3358
3359 package CPAN::FTP::netrc;
3360 use strict;
3361
3362 # package CPAN::FTP::netrc;
3363 sub new {
3364     my($class) = @_;
3365     my $home = CPAN::HandleConfig::home;
3366     my $file = File::Spec->catfile($home,".netrc");
3367
3368     my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
3369        $atime,$mtime,$ctime,$blksize,$blocks)
3370         = stat($file);
3371     $mode ||= 0;
3372     my $protected = 0;
3373
3374     my($fh,@machines,$hasdefault);
3375     $hasdefault = 0;
3376     $fh = FileHandle->new or die "Could not create a filehandle";
3377
3378     if($fh->open($file)){
3379         $protected = ($mode & 077) == 0;
3380         local($/) = "";
3381       NETRC: while (<$fh>) {
3382             my(@tokens) = split " ", $_;
3383           TOKEN: while (@tokens) {
3384                 my($t) = shift @tokens;
3385                 if ($t eq "default"){
3386                     $hasdefault++;
3387                     last NETRC;
3388                 }
3389                 last TOKEN if $t eq "macdef";
3390                 if ($t eq "machine") {
3391                     push @machines, shift @tokens;
3392                 }
3393             }
3394         }
3395     } else {
3396         $file = $hasdefault = $protected = "";
3397     }
3398
3399     bless {
3400            'mach' => [@machines],
3401            'netrc' => $file,
3402            'hasdefault' => $hasdefault,
3403            'protected' => $protected,
3404           }, $class;
3405 }
3406
3407 # CPAN::FTP::netrc::hasdefault;
3408 sub hasdefault { shift->{'hasdefault'} }
3409 sub netrc      { shift->{'netrc'}      }
3410 sub protected  { shift->{'protected'}  }
3411 sub contains {
3412     my($self,$mach) = @_;
3413     for ( @{$self->{'mach'}} ) {
3414         return 1 if $_ eq $mach;
3415     }
3416     return 0;
3417 }
3418
3419 package CPAN::Complete;
3420 use strict;
3421
3422 sub gnu_cpl {
3423     my($text, $line, $start, $end) = @_;
3424     my(@perlret) = cpl($text, $line, $start);
3425     # find longest common match. Can anybody show me how to peruse
3426     # T::R::Gnu to have this done automatically? Seems expensive.
3427     return () unless @perlret;
3428     my($newtext) = $text;
3429     for (my $i = length($text)+1;;$i++) {
3430         last unless length($perlret[0]) && length($perlret[0]) >= $i;
3431         my $try = substr($perlret[0],0,$i);
3432         my @tries = grep {substr($_,0,$i) eq $try} @perlret;
3433         # warn "try[$try]tries[@tries]";
3434         if (@tries == @perlret) {
3435             $newtext = $try;
3436         } else {
3437             last;
3438         }
3439     }
3440     ($newtext,@perlret);
3441 }
3442
3443 #-> sub CPAN::Complete::cpl ;
3444 sub cpl {
3445     my($word,$line,$pos) = @_;
3446     $word ||= "";
3447     $line ||= "";
3448     $pos ||= 0;
3449     CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
3450     $line =~ s/^\s*//;
3451     if ($line =~ s/^(force\s*)//) {
3452         $pos -= length($1);
3453     }
3454     my @return;
3455     if ($pos == 0) {
3456         @return = grep /^$word/, @CPAN::Complete::COMMANDS;
3457     } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
3458         @return = ();
3459     } elsif ($line =~ /^(a|ls)\s/) {
3460         @return = cplx('CPAN::Author',uc($word));
3461     } elsif ($line =~ /^b\s/) {
3462         CPAN::Shell->local_bundles;
3463         @return = cplx('CPAN::Bundle',$word);
3464     } elsif ($line =~ /^d\s/) {
3465         @return = cplx('CPAN::Distribution',$word);
3466     } elsif ($line =~ m/^(
3467                           [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
3468                          )\s/x ) {
3469         if ($word =~ /^Bundle::/) {
3470             CPAN::Shell->local_bundles;
3471         }
3472         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
3473     } elsif ($line =~ /^i\s/) {
3474         @return = cpl_any($word);
3475     } elsif ($line =~ /^reload\s/) {
3476         @return = cpl_reload($word,$line,$pos);
3477     } elsif ($line =~ /^o\s/) {
3478         @return = cpl_option($word,$line,$pos);
3479     } elsif ($line =~ m/^\S+\s/ ) {
3480         # fallback for future commands and what we have forgotten above
3481         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
3482     } else {
3483         @return = ();
3484     }
3485     return @return;
3486 }
3487
3488 #-> sub CPAN::Complete::cplx ;
3489 sub cplx {
3490     my($class, $word) = @_;
3491     # I believed for many years that this was sorted, today I
3492     # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
3493     # make it sorted again. Maybe sort was dropped when GNU-readline
3494     # support came in? The RCS file is difficult to read on that:-(
3495     sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
3496 }
3497
3498 #-> sub CPAN::Complete::cpl_any ;
3499 sub cpl_any {
3500     my($word) = shift;
3501     return (
3502             cplx('CPAN::Author',$word),
3503             cplx('CPAN::Bundle',$word),
3504             cplx('CPAN::Distribution',$word),
3505             cplx('CPAN::Module',$word),
3506            );
3507 }
3508
3509 #-> sub CPAN::Complete::cpl_reload ;
3510 sub cpl_reload {
3511     my($word,$line,$pos) = @_;
3512     $word ||= "";
3513     my(@words) = split " ", $line;
3514     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
3515     my(@ok) = qw(cpan index);
3516     return @ok if @words == 1;
3517     return grep /^\Q$word\E/, @ok if @words == 2 && $word;
3518 }
3519
3520 #-> sub CPAN::Complete::cpl_option ;
3521 sub cpl_option {
3522     my($word,$line,$pos) = @_;
3523     $word ||= "";
3524     my(@words) = split " ", $line;
3525     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
3526     my(@ok) = qw(conf debug);
3527     return @ok if @words == 1;
3528     return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
3529     if (0) {
3530     } elsif ($words[1] eq 'index') {
3531         return ();
3532     } elsif ($words[1] eq 'conf') {
3533         return CPAN::HandleConfig::cpl(@_);
3534     } elsif ($words[1] eq 'debug') {
3535         return sort grep /^\Q$word\E/i,
3536             sort keys %CPAN::DEBUG, 'all';
3537     }
3538 }
3539
3540 package CPAN::Index;
3541 use strict;
3542
3543 #-> sub CPAN::Index::force_reload ;
3544 sub force_reload {
3545     my($class) = @_;
3546     $CPAN::Index::LAST_TIME = 0;
3547     $class->reload(1);
3548 }
3549
3550 #-> sub CPAN::Index::reload ;
3551 sub reload {
3552     my($cl,$force) = @_;
3553     my $time = time;
3554
3555     # XXX check if a newer one is available. (We currently read it
3556     # from time to time)
3557     for ($CPAN::Config->{index_expire}) {
3558         $_ = 0.001 unless $_ && $_ > 0.001;
3559     }
3560     unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
3561         # debug here when CPAN doesn't seem to read the Metadata
3562         require Carp;
3563         Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
3564     }
3565     unless ($CPAN::META->{PROTOCOL}) {
3566         $cl->read_metadata_cache;
3567         $CPAN::META->{PROTOCOL} ||= "1.0";
3568     }
3569     if ( $CPAN::META->{PROTOCOL} < PROTOCOL  ) {
3570         # warn "Setting last_time to 0";
3571         $LAST_TIME = 0; # No warning necessary
3572     }
3573     return if $LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
3574         and ! $force;
3575     if (0) {
3576         # IFF we are developing, it helps to wipe out the memory
3577         # between reloads, otherwise it is not what a user expects.
3578         undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
3579         $CPAN::META = CPAN->new;
3580     }
3581     {
3582         my($debug,$t2);
3583         local $LAST_TIME = $time;
3584         local $CPAN::META->{PROTOCOL} = PROTOCOL;
3585
3586         my $needshort = $^O eq "dos";
3587
3588         $cl->rd_authindex($cl
3589                           ->reload_x(
3590                                      "authors/01mailrc.txt.gz",
3591                                      $needshort ?
3592                                      File::Spec->catfile('authors', '01mailrc.gz') :
3593                                      File::Spec->catfile('authors', '01mailrc.txt.gz'),
3594                                      $force));
3595         $t2 = time;
3596         $debug = "timing reading 01[".($t2 - $time)."]";
3597         $time = $t2;
3598         return if $CPAN::Signal; # this is sometimes lengthy
3599         $cl->rd_modpacks($cl
3600                          ->reload_x(
3601                                     "modules/02packages.details.txt.gz",
3602                                     $needshort ?
3603                                     File::Spec->catfile('modules', '02packag.gz') :
3604                                     File::Spec->catfile('modules', '02packages.details.txt.gz'),
3605                                     $force));
3606         $t2 = time;
3607         $debug .= "02[".($t2 - $time)."]";
3608         $time = $t2;
3609         return if $CPAN::Signal; # this is sometimes lengthy
3610         $cl->rd_modlist($cl
3611                         ->reload_x(
3612                                    "modules/03modlist.data.gz",
3613                                    $needshort ?
3614                                    File::Spec->catfile('modules', '03mlist.gz') :
3615                                    File::Spec->catfile('modules', '03modlist.data.gz'),
3616                                    $force));
3617         $cl->write_metadata_cache;
3618         $t2 = time;
3619         $debug .= "03[".($t2 - $time)."]";
3620         $time = $t2;
3621         CPAN->debug($debug) if $CPAN::DEBUG;
3622     }
3623     $LAST_TIME = $time;
3624     $CPAN::META->{PROTOCOL} = PROTOCOL;
3625 }
3626
3627 #-> sub CPAN::Index::reload_x ;
3628 sub reload_x {
3629     my($cl,$wanted,$localname,$force) = @_;
3630     $force |= 2; # means we're dealing with an index here
3631     CPAN::HandleConfig->load; # we should guarantee loading wherever
3632                               # we rely on Config XXX
3633     $localname ||= $wanted;
3634     my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
3635                                          $localname);
3636     if (
3637         -f $abs_wanted &&
3638         -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
3639         !($force & 1)
3640        ) {
3641         my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
3642         $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
3643                    qq{day$s. I\'ll use that.});
3644         return $abs_wanted;
3645     } else {
3646         $force |= 1; # means we're quite serious about it.
3647     }
3648     return CPAN::FTP->localize($wanted,$abs_wanted,$force);
3649 }
3650
3651 #-> sub CPAN::Index::rd_authindex ;
3652 sub rd_authindex {
3653     my($cl, $index_target) = @_;
3654     my @lines;
3655     return unless defined $index_target;
3656     $CPAN::Frontend->myprint("Going to read $index_target\n");
3657     local(*FH);
3658     tie *FH, 'CPAN::Tarzip', $index_target;
3659     local($/) = "\n";
3660     local($_);
3661     push @lines, split /\012/ while <FH>;
3662     foreach (@lines) {
3663         my($userid,$fullname,$email) =
3664             m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
3665         next unless $userid && $fullname && $email;
3666
3667         # instantiate an author object
3668         my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
3669         $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
3670         return if $CPAN::Signal;
3671     }
3672 }
3673
3674 sub userid {
3675   my($self,$dist) = @_;
3676   $dist = $self->{'id'} unless defined $dist;
3677   my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
3678   $ret;
3679 }
3680
3681 #-> sub CPAN::Index::rd_modpacks ;
3682 sub rd_modpacks {
3683     my($self, $index_target) = @_;
3684     my @lines;
3685     return unless defined $index_target;
3686     $CPAN::Frontend->myprint("Going to read $index_target\n");
3687     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3688     local($/) = "\n";
3689     local $_;
3690     while ($_ = $fh->READLINE) {
3691         s/\012/\n/g;
3692         my @ls = map {"$_\n"} split /\n/, $_;
3693         unshift @ls, "\n" x length($1) if /^(\n+)/;
3694         push @lines, @ls;
3695     }
3696     # read header
3697     my($line_count,$last_updated);
3698     while (@lines) {
3699         my $shift = shift(@lines);
3700         last if $shift =~ /^\s*$/;
3701         $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
3702         $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
3703     }
3704     if (not defined $line_count) {
3705
3706         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
3707 Please check the validity of the index file by comparing it to more
3708 than one CPAN mirror. I'll continue but problems seem likely to
3709 happen.\a
3710 });
3711
3712         $CPAN::Frontend->mysleep(5);
3713     } elsif ($line_count != scalar @lines) {
3714
3715         $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
3716 contains a Line-Count header of %d but I see %d lines there. Please
3717 check the validity of the index file by comparing it to more than one
3718 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
3719 $index_target, $line_count, scalar(@lines));
3720
3721     }
3722     if (not defined $last_updated) {
3723
3724         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
3725 Please check the validity of the index file by comparing it to more
3726 than one CPAN mirror. I'll continue but problems seem likely to
3727 happen.\a
3728 });
3729
3730         $CPAN::Frontend->mysleep(5);
3731     } else {
3732
3733         $CPAN::Frontend
3734             ->myprint(sprintf qq{  Database was generated on %s\n},
3735                       $last_updated);
3736         $DATE_OF_02 = $last_updated;
3737
3738         my $age = time;
3739         if ($CPAN::META->has_inst('HTTP::Date')) {
3740             require HTTP::Date;
3741             $age -= HTTP::Date::str2time($last_updated);
3742         } else {
3743             $CPAN::Frontend->mywarn("  HTTP::Date not available\n");
3744             require Time::Local;
3745             my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
3746             $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
3747             $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
3748         }
3749         $age /= 3600*24;
3750         if ($age > 30) {
3751
3752             $CPAN::Frontend
3753                 ->mywarn(sprintf
3754                          qq{Warning: This index file is %d days old.
3755   Please check the host you chose as your CPAN mirror for staleness.
3756   I'll continue but problems seem likely to happen.\a\n},
3757                          $age);
3758
3759         } elsif ($age < -1) {
3760
3761             $CPAN::Frontend
3762                 ->mywarn(sprintf
3763                          qq{Warning: Your system date is %d days behind this index file!
3764   System time:          %s
3765   Timestamp index file: %s
3766   Please fix your system time, problems with the make command expected.\n},
3767                          -$age,
3768                          scalar gmtime,
3769                          $DATE_OF_02,
3770                         );
3771
3772         }
3773     }
3774
3775
3776     # A necessity since we have metadata_cache: delete what isn't
3777     # there anymore
3778     my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
3779     CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
3780     my(%exists);
3781     foreach (@lines) {
3782         chomp;
3783         # before 1.56 we split into 3 and discarded the rest. From
3784         # 1.57 we assign remaining text to $comment thus allowing to
3785         # influence isa_perl
3786         my($mod,$version,$dist,$comment) = split " ", $_, 4;
3787         my($bundle,$id,$userid);
3788
3789         if ($mod eq 'CPAN' &&
3790             ! (
3791                CPAN::Queue->exists('Bundle::CPAN') ||
3792                CPAN::Queue->exists('CPAN')
3793               )
3794            ) {
3795             local($^W)= 0;
3796             if ($version > $CPAN::VERSION){
3797                 $CPAN::Frontend->mywarn(qq{
3798   New CPAN.pm version (v$version) available.
3799   [Currently running version is v$CPAN::VERSION]
3800   You might want to try
3801     install CPAN
3802     reload cpan
3803   to both upgrade CPAN.pm and run the new version without leaving
3804   the current session.
3805
3806 }); #});
3807                 $CPAN::Frontend->mysleep(2);
3808                 $CPAN::Frontend->myprint(qq{\n});
3809             }
3810             last if $CPAN::Signal;
3811         } elsif ($mod =~ /^Bundle::(.*)/) {
3812             $bundle = $1;
3813         }
3814
3815         if ($bundle){
3816             $id =  $CPAN::META->instance('CPAN::Bundle',$mod);
3817             # Let's make it a module too, because bundles have so much
3818             # in common with modules.
3819
3820             # Changed in 1.57_63: seems like memory bloat now without
3821             # any value, so commented out
3822
3823             # $CPAN::META->instance('CPAN::Module',$mod);
3824
3825         } else {
3826
3827             # instantiate a module object
3828             $id = $CPAN::META->instance('CPAN::Module',$mod);
3829
3830         }
3831
3832         # Although CPAN prohibits same name with different version the
3833         # indexer may have changed the version for the same distro
3834         # since the last time ("Force Reindexing" feature)
3835         if ($id->cpan_file ne $dist
3836             ||
3837             $id->cpan_version ne $version
3838            ){
3839             $userid = $id->userid || $self->userid($dist);
3840             $id->set(
3841                      'CPAN_USERID' => $userid,
3842                      'CPAN_VERSION' => $version,
3843                      'CPAN_FILE' => $dist,
3844                     );
3845         }
3846
3847         # instantiate a distribution object
3848         if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
3849           # we do not need CONTAINSMODS unless we do something with
3850           # this dist, so we better produce it on demand.
3851
3852           ## my $obj = $CPAN::META->instance(
3853           ##                              'CPAN::Distribution' => $dist
3854           ##                             );
3855           ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
3856         } else {
3857           $CPAN::META->instance(
3858                                 'CPAN::Distribution' => $dist
3859                                )->set(
3860                                       'CPAN_USERID' => $userid,
3861                                       'CPAN_COMMENT' => $comment,
3862                                      );
3863         }
3864         if ($secondtime) {
3865             for my $name ($mod,$dist) {
3866                 CPAN->debug("exists name[$name]") if $CPAN::DEBUG;
3867                 $exists{$name} = undef;
3868             }
3869         }
3870         return if $CPAN::Signal;
3871     }
3872     undef $fh;
3873     if ($secondtime) {
3874         for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
3875             for my $o ($CPAN::META->all_objects($class)) {
3876                 next if exists $exists{$o->{ID}};
3877                 $CPAN::META->delete($class,$o->{ID});
3878                 CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
3879                     if $CPAN::DEBUG;
3880             }
3881         }
3882     }
3883 }
3884
3885 #-> sub CPAN::Index::rd_modlist ;
3886 sub rd_modlist {
3887     my($cl,$index_target) = @_;
3888     return unless defined $index_target;
3889     $CPAN::Frontend->myprint("Going to read $index_target\n");
3890     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3891     my @eval;
3892     local($/) = "\n";
3893     local $_;
3894     while ($_ = $fh->READLINE) {
3895         s/\012/\n/g;
3896         my @ls = map {"$_\n"} split /\n/, $_;
3897         unshift @ls, "\n" x length($1) if /^(\n+)/;
3898         push @eval, @ls;
3899     }
3900     while (@eval) {
3901         my $shift = shift(@eval);
3902         if ($shift =~ /^Date:\s+(.*)/){
3903             return if $DATE_OF_03 eq $1;
3904             ($DATE_OF_03) = $1;
3905         }
3906         last if $shift =~ /^\s*$/;
3907     }
3908     undef $fh;
3909     push @eval, q{CPAN::Modulelist->data;};
3910     local($^W) = 0;
3911     my($comp) = Safe->new("CPAN::Safe1");
3912     my($eval) = join("", @eval);
3913     my $ret = $comp->reval($eval);
3914     Carp::confess($@) if $@;
3915     return if $CPAN::Signal;
3916     for (keys %$ret) {
3917         my $obj = $CPAN::META->instance("CPAN::Module",$_);
3918         delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
3919         $obj->set(%{$ret->{$_}});
3920         return if $CPAN::Signal;
3921     }
3922 }
3923
3924 #-> sub CPAN::Index::write_metadata_cache ;
3925 sub write_metadata_cache {
3926     my($self) = @_;
3927     return unless $CPAN::Config->{'cache_metadata'};
3928     return unless $CPAN::META->has_usable("Storable");
3929     my $cache;
3930     foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
3931                       CPAN::Distribution)) {
3932         $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
3933     }
3934     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
3935     $cache->{last_time} = $LAST_TIME;
3936     $cache->{DATE_OF_02} = $DATE_OF_02;
3937     $cache->{PROTOCOL} = PROTOCOL;
3938     $CPAN::Frontend->myprint("Going to write $metadata_file\n");
3939     eval { Storable::nstore($cache, $metadata_file) };
3940     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
3941 }
3942
3943 #-> sub CPAN::Index::read_metadata_cache ;
3944 sub read_metadata_cache {
3945     my($self) = @_;
3946     return unless $CPAN::Config->{'cache_metadata'};
3947     return unless $CPAN::META->has_usable("Storable");
3948     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
3949     return unless -r $metadata_file and -f $metadata_file;
3950     $CPAN::Frontend->myprint("Going to read $metadata_file\n");
3951     my $cache;
3952     eval { $cache = Storable::retrieve($metadata_file) };
3953     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
3954     if (!$cache || ref $cache ne 'HASH'){
3955         $LAST_TIME = 0;
3956         return;
3957     }
3958     if (exists $cache->{PROTOCOL}) {
3959         if (PROTOCOL > $cache->{PROTOCOL}) {
3960             $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
3961                                             "with protocol v%s, requiring v%s\n",
3962                                             $cache->{PROTOCOL},
3963                                             PROTOCOL)
3964                                    );
3965             return;
3966         }
3967     } else {
3968         $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
3969                                 "with protocol v1.0\n");
3970         return;
3971     }
3972     my $clcnt = 0;
3973     my $idcnt = 0;
3974     while(my($class,$v) = each %$cache) {
3975         next unless $class =~ /^CPAN::/;
3976         $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
3977         while (my($id,$ro) = each %$v) {
3978             $CPAN::META->{readwrite}{$class}{$id} ||=
3979                 $class->new(ID=>$id, RO=>$ro);
3980             $idcnt++;
3981         }
3982         $clcnt++;
3983     }
3984     unless ($clcnt) { # sanity check
3985         $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
3986         return;
3987     }
3988     if ($idcnt < 1000) {
3989         $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
3990                                  "in $metadata_file\n");
3991         return;
3992     }
3993     $CPAN::META->{PROTOCOL} ||=
3994         $cache->{PROTOCOL}; # reading does not up or downgrade, but it
3995                             # does initialize to some protocol
3996     $LAST_TIME = $cache->{last_time};
3997     $DATE_OF_02 = $cache->{DATE_OF_02};
3998     $CPAN::Frontend->myprint("  Database was generated on $DATE_OF_02\n")
3999         if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
4000     return;
4001 }
4002
4003 package CPAN::InfoObj;
4004 use strict;
4005
4006 sub ro {
4007     my $self = shift;
4008     exists $self->{RO} and return $self->{RO};
4009 }
4010
4011 sub cpan_userid {
4012     my $self = shift;
4013     my $ro = $self->ro or return "N/A"; # N/A for bundles found locally
4014     return $ro->{CPAN_USERID} || "N/A";
4015 }
4016
4017 sub id { shift->{ID}; }
4018
4019 #-> sub CPAN::InfoObj::new ;
4020 sub new {
4021     my $this = bless {}, shift;
4022     %$this = @_;
4023     $this
4024 }
4025
4026 # The set method may only be used by code that reads index data or
4027 # otherwise "objective" data from the outside world. All session
4028 # related material may do anything else with instance variables but
4029 # must not touch the hash under the RO attribute. The reason is that
4030 # the RO hash gets written to Metadata file and is thus persistent.
4031
4032 #-> sub CPAN::InfoObj::safe_chdir ;
4033 sub safe_chdir {
4034   my($self,$todir) = @_;
4035   # we die if we cannot chdir and we are debuggable
4036   Carp::confess("safe_chdir called without todir argument")
4037         unless defined $todir and length $todir;
4038   if (chdir $todir) {
4039     $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
4040         if $CPAN::DEBUG;
4041   } else {
4042     if (-e $todir) {
4043         unless (-x $todir) {
4044             unless (chmod 0755, $todir) {
4045                 my $cwd = CPAN::anycwd();
4046                 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
4047                                         "permission to change the permission; cannot ".
4048                                         "chdir to '$todir'\n");
4049                 $CPAN::Frontend->mysleep(5);
4050                 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
4051                                        qq{to todir[$todir]: $!});
4052             }
4053         }
4054     } else {
4055         $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n");
4056     }
4057     if (chdir $todir) {
4058       $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
4059           if $CPAN::DEBUG;
4060     } else {
4061       my $cwd = CPAN::anycwd();
4062       $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
4063                              qq{to todir[$todir] (a chmod has been issued): $!});
4064     }
4065   }
4066 }
4067
4068 #-> sub CPAN::InfoObj::set ;
4069 sub set {
4070     my($self,%att) = @_;
4071     my $class = ref $self;
4072
4073     # This must be ||=, not ||, because only if we write an empty
4074     # reference, only then the set method will write into the readonly
4075     # area. But for Distributions that spring into existence, maybe
4076     # because of a typo, we do not like it that they are written into
4077     # the readonly area and made permanent (at least for a while) and
4078     # that is why we do not "allow" other places to call ->set.
4079     unless ($self->id) {
4080         CPAN->debug("Bug? Empty ID, rejecting");
4081         return;
4082     }
4083     my $ro = $self->{RO} =
4084         $CPAN::META->{readonly}{$class}{$self->id} ||= {};
4085
4086     while (my($k,$v) = each %att) {
4087         $ro->{$k} = $v;
4088     }
4089 }
4090
4091 #-> sub CPAN::InfoObj::as_glimpse ;
4092 sub as_glimpse {
4093     my($self) = @_;
4094     my(@m);
4095     my $class = ref($self);
4096     $class =~ s/^CPAN:://;
4097     my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID};
4098     push @m, sprintf "%-15s %s\n", $class, $id;
4099     join "", @m;
4100 }
4101
4102 #-> sub CPAN::InfoObj::as_string ;
4103 sub as_string {
4104     my($self) = @_;
4105     my(@m);
4106     my $class = ref($self);
4107     $class =~ s/^CPAN:://;
4108     push @m, $class, " id = $self->{ID}\n";
4109     my $ro;
4110     unless ($ro = $self->ro) {
4111         $CPAN::Frontend->mydie("Unknown object $self->{ID}");
4112     }
4113     for (sort keys %$ro) {
4114         # next if m/^(ID|RO)$/;
4115         my $extra = "";
4116         if ($_ eq "CPAN_USERID") {
4117             $extra .= " (";
4118             $extra .= $self->fullname;
4119             my $email; # old perls!
4120             if ($email = $CPAN::META->instance("CPAN::Author",
4121                                                $self->cpan_userid
4122                                               )->email) {
4123                 $extra .= " <$email>";
4124             } else {
4125                 $extra .= " <no email>";
4126             }
4127             $extra .= ")";
4128         } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
4129             push @m, sprintf "    %-12s %s\n", $_, $self->fullname;
4130             next;
4131         }
4132         next unless defined $ro->{$_};
4133         push @m, sprintf "    %-12s %s%s\n", $_, $ro->{$_}, $extra;
4134     }
4135     for (sort keys %$self) {
4136         next if m/^(ID|RO)$/;
4137         if (ref($self->{$_}) eq "ARRAY") {
4138           push @m, sprintf "    %-12s %s\n", $_, "@{$self->{$_}}";
4139         } elsif (ref($self->{$_}) eq "HASH") {
4140           push @m, sprintf(
4141                            "    %-12s %s\n",
4142                            $_,
4143                            join(" ",sort keys %{$self->{$_}}),
4144                           );
4145         } else {
4146           push @m, sprintf "    %-12s %s\n", $_, $self->{$_};
4147         }
4148     }
4149     join "", @m, "\n";
4150 }
4151
4152 #-> sub CPAN::InfoObj::fullname ;
4153 sub fullname {
4154     my($self) = @_;
4155     $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
4156 }
4157
4158 #-> sub CPAN::InfoObj::dump ;
4159 sub dump {
4160   my($self, $what) = @_;
4161   unless ($CPAN::META->has_inst("Data::Dumper")) {
4162       $CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
4163   }
4164   local $Data::Dumper::Sortkeys;
4165   $Data::Dumper::Sortkeys = 1;
4166   my $out = Data::Dumper::Dumper($what ? eval $what : $self);
4167   if (length $out > 100000) {
4168       my $fh_pager = FileHandle->new;
4169       local($SIG{PIPE}) = "IGNORE";
4170       my $pager = $CPAN::Config->{'pager'} || "cat";
4171       $fh_pager->open("|$pager")
4172           or die "Could not open pager $pager\: $!";
4173       $fh_pager->print($out);
4174       close $fh_pager;
4175   } else {
4176       $CPAN::Frontend->myprint($out);
4177   }
4178 }
4179
4180 package CPAN::Author;
4181 use strict;
4182
4183 #-> sub CPAN::Author::force
4184 sub force {
4185     my $self = shift;
4186     $self->{force}++;
4187 }
4188
4189 #-> sub CPAN::Author::force
4190 sub unforce {
4191     my $self = shift;
4192     delete $self->{force};
4193 }
4194
4195 #-> sub CPAN::Author::id
4196 sub id {
4197     my $self = shift;
4198     my $id = $self->{ID};
4199     $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
4200     $id;
4201 }
4202
4203 #-> sub CPAN::Author::as_glimpse ;
4204 sub as_glimpse {
4205     my($self) = @_;
4206     my(@m);
4207     my $class = ref($self);
4208     $class =~ s/^CPAN:://;
4209     push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
4210                      $class,
4211                      $self->{ID},
4212                      $self->fullname,
4213                      $self->email);
4214     join "", @m;
4215 }
4216
4217 #-> sub CPAN::Author::fullname ;
4218 sub fullname {
4219     shift->ro->{FULLNAME};
4220 }
4221 *name = \&fullname;
4222
4223 #-> sub CPAN::Author::email ;
4224 sub email    { shift->ro->{EMAIL}; }
4225
4226 #-> sub CPAN::Author::ls ;
4227 sub ls {
4228     my $self = shift;
4229     my $glob = shift || "";
4230     my $silent = shift || 0;
4231     my $id = $self->id;
4232
4233     # adapted from CPAN::Distribution::verifyCHECKSUM ;
4234     my(@csf); # chksumfile
4235     @csf = $self->id =~ /(.)(.)(.*)/;
4236     $csf[1] = join "", @csf[0,1];
4237     $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
4238     my(@dl);
4239     @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
4240     unless (grep {$_->[2] eq $csf[1]} @dl) {
4241         $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
4242         return;
4243     }
4244     @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
4245     unless (grep {$_->[2] eq $csf[2]} @dl) {
4246         $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
4247         return;
4248     }
4249     @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
4250     if ($glob) {
4251         if ($CPAN::META->has_inst("Text::Glob")) {
4252             my $rglob = Text::Glob::glob_to_regex($glob);
4253             @dl = grep { $_->[2] =~ /$rglob/ } @dl;
4254         } else {
4255             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
4256         }
4257     }
4258     $CPAN::Frontend->myprint(join "", map {
4259         sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
4260     } sort { $a->[2] cmp $b->[2] } @dl);
4261     @dl;
4262 }
4263
4264 # returns an array of arrays, the latter contain (size,mtime,filename)
4265 #-> sub CPAN::Author::dir_listing ;
4266 sub dir_listing {
4267     my $self = shift;
4268     my $chksumfile = shift;
4269     my $recursive = shift;
4270     my $may_ftp = shift;
4271
4272     my $lc_want =
4273         File::Spec->catfile($CPAN::Config->{keep_source_where},
4274                             "authors", "id", @$chksumfile);
4275
4276     my $fh;
4277
4278     # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
4279     # hazard.  (Without GPG installed they are not that much better,
4280     # though.)
4281     $fh = FileHandle->new;
4282     if (open($fh, $lc_want)) {
4283         my $line = <$fh>; close $fh;
4284         unlink($lc_want) unless $line =~ /PGP/;
4285     }
4286
4287     local($") = "/";
4288     # connect "force" argument with "index_expire".
4289     my $force = $self->{force};
4290     if (my @stat = stat $lc_want) {
4291         $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
4292     }
4293     my $lc_file;
4294     if ($may_ftp) {
4295         $lc_file = CPAN::FTP->localize(
4296                                        "authors/id/@$chksumfile",
4297                                        $lc_want,
4298                                        $force,
4299                                       );
4300         unless ($lc_file) {
4301             $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
4302             $chksumfile->[-1] .= ".gz";
4303             $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
4304                                            "$lc_want.gz",1);
4305             if ($lc_file) {
4306                 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
4307                 CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file);
4308             } else {
4309                 return;
4310             }
4311         }
4312     } else {
4313         $lc_file = $lc_want;
4314         # we *could* second-guess and if the user has a file: URL,
4315         # then we could look there. But on the other hand, if they do
4316         # have a file: URL, wy did they choose to set
4317         # $CPAN::Config->{show_upload_date} to false?
4318     }
4319
4320     # adapted from CPAN::Distribution::CHECKSUM_check_file ;
4321     $fh = FileHandle->new;
4322     my($cksum);
4323     if (open $fh, $lc_file){
4324         local($/);
4325         my $eval = <$fh>;
4326         $eval =~ s/\015?\012/\n/g;
4327         close $fh;
4328         my($comp) = Safe->new();
4329         $cksum = $comp->reval($eval);
4330         if ($@) {
4331             rename $lc_file, "$lc_file.bad";
4332             Carp::confess($@) if $@;
4333         }
4334     } elsif ($may_ftp) {
4335         Carp::carp "Could not open '$lc_file' for reading.";
4336     } else {
4337         # Maybe should warn: "You may want to set show_upload_date to a true value"
4338         return;
4339     }
4340     my(@result,$f);
4341     for $f (sort keys %$cksum) {
4342         if (exists $cksum->{$f}{isdir}) {
4343             if ($recursive) {
4344                 my(@dir) = @$chksumfile;
4345                 pop @dir;
4346                 push @dir, $f, "CHECKSUMS";
4347                 push @result, map {
4348                     [$_->[0], $_->[1], "$f/$_->[2]"]
4349                 } $self->dir_listing(\@dir,1,$may_ftp);
4350             } else {
4351                 push @result, [ 0, "-", $f ];
4352             }
4353         } else {
4354             push @result, [
4355                            ($cksum->{$f}{"size"}||0),
4356                            $cksum->{$f}{"mtime"}||"---",
4357                            $f
4358                           ];
4359         }
4360     }
4361     @result;
4362 }
4363
4364 package CPAN::Distribution;
4365 use strict;
4366
4367 # Accessors
4368 sub cpan_comment {
4369     my $self = shift;
4370     my $ro = $self->ro or return;
4371     $ro->{CPAN_COMMENT}
4372 }
4373
4374 # CPAN::Distribution::undelay
4375 sub undelay {
4376     my $self = shift;
4377     delete $self->{later};
4378 }
4379
4380 # add the A/AN/ stuff
4381 # CPAN::Distribution::normalize
4382 sub normalize {
4383     my($self,$s) = @_;
4384     $s = $self->id unless defined $s;
4385     if (
4386         $s =~ tr|/|| == 1
4387         or
4388         $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
4389        ) {
4390         return $s if $s =~ m:^N/A|^Contact Author: ;
4391         $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
4392             $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
4393         CPAN->debug("s[$s]") if $CPAN::DEBUG;
4394     }
4395     $s;
4396 }
4397
4398 #-> sub CPAN::Distribution::author ;
4399 sub author {
4400     my($self) = @_;
4401     my($authorid) = $self->pretty_id =~ /^([\w\-]+)/;
4402     CPAN::Shell->expand("Author",$authorid);
4403 }
4404
4405 # tries to get the yaml from CPAN instead of the distro itself:
4406 # EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels
4407 sub fast_yaml {
4408     my($self) = @_;
4409     my $meta = $self->pretty_id;
4410     $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/;
4411     my(@ls) = CPAN::Shell->globls($meta);
4412     my $norm = $self->normalize($meta);
4413
4414     my($local_file);
4415     my($local_wanted) =
4416         File::Spec->catfile(
4417                             $CPAN::Config->{keep_source_where},
4418                             "authors",
4419                             "id",
4420                             split(/\//,$norm)
4421                            );
4422     $self->debug("Doing localize") if $CPAN::DEBUG;
4423     unless ($local_file =
4424             CPAN::FTP->localize("authors/id/$norm",
4425                                 $local_wanted)) {
4426         $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n");
4427     }
4428     if ($CPAN::META->has_inst("YAML")) {
4429         my $yaml = YAML::LoadFile($local_file);
4430         return $yaml;
4431     } else {
4432         $CPAN::Frontend->mydie("Yaml not installed, cannot parse '$local_file'\n");
4433     }
4434 }
4435
4436 #-> sub CPAN::Distribution::pretty_id
4437 sub pretty_id {
4438     my $self = shift;
4439     my $id = $self->id;
4440     return $id unless $id =~ m|^./../|;
4441     substr($id,5);
4442 }
4443
4444 # mark as dirty/clean
4445 #-> sub CPAN::Distribution::color_cmd_tmps ;
4446 sub color_cmd_tmps {
4447     my($self) = shift;
4448     my($depth) = shift || 0;
4449     my($color) = shift || 0;
4450     my($ancestors) = shift || [];
4451     # a distribution needs to recurse into its prereq_pms
4452
4453     return if exists $self->{incommandcolor}
4454         && $self->{incommandcolor}==$color;
4455     if ($depth>=100){
4456         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
4457     }
4458     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
4459     my $prereq_pm = $self->prereq_pm;
4460     if (defined $prereq_pm) {
4461       PREREQ: for my $pre (keys %{$prereq_pm->{requires}||{}},
4462                            keys %{$prereq_pm->{build_requires}||{}}) {
4463             my $premo;
4464             unless ($premo = CPAN::Shell->expand("Module",$pre)) {
4465                 $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n");
4466                 $CPAN::Frontend->mysleep(2);
4467                 next PREREQ;
4468             }
4469             $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
4470         }
4471     }
4472     if ($color==0) {
4473         delete $self->{sponsored_mods};
4474         delete $self->{badtestcnt};
4475     }
4476     $self->{incommandcolor} = $color;
4477 }
4478
4479 #-> sub CPAN::Distribution::as_string ;
4480 sub as_string {
4481   my $self = shift;
4482   $self->containsmods;
4483   $self->upload_date;
4484   $self->SUPER::as_string(@_);
4485 }
4486
4487 #-> sub CPAN::Distribution::containsmods ;
4488 sub containsmods {
4489   my $self = shift;
4490   return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
4491   my $dist_id = $self->{ID};
4492   for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
4493     my $mod_file = $mod->cpan_file or next;
4494     my $mod_id = $mod->{ID} or next;
4495     # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
4496     # sleep 1;
4497     $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
4498   }
4499   keys %{$self->{CONTAINSMODS}};
4500 }
4501
4502 #-> sub CPAN::Distribution::upload_date ;
4503 sub upload_date {
4504   my $self = shift;
4505   return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
4506   my(@local_wanted) = split(/\//,$self->id);
4507   my $filename = pop @local_wanted;
4508   push @local_wanted, "CHECKSUMS";
4509   my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
4510   return unless $author;
4511   my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
4512   return unless @dl;
4513   my($dirent) = grep { $_->[2] eq $filename } @dl;
4514   # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
4515   return unless $dirent->[1];
4516   return $self->{UPLOAD_DATE} = $dirent->[1];
4517 }
4518
4519 #-> sub CPAN::Distribution::uptodate ;
4520 sub uptodate {
4521     my($self) = @_;
4522     my $c;
4523     foreach $c ($self->containsmods) {
4524         my $obj = CPAN::Shell->expandany($c);
4525         unless ($obj->uptodate){
4526             my $id = $self->pretty_id;
4527             $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG;
4528             return 0;
4529         }
4530     }
4531     return 1;
4532 }
4533
4534 #-> sub CPAN::Distribution::called_for ;
4535 sub called_for {
4536     my($self,$id) = @_;
4537     $self->{CALLED_FOR} = $id if defined $id;
4538     return $self->{CALLED_FOR};
4539 }
4540
4541 #-> sub CPAN::Distribution::get ;
4542 sub get {
4543     my($self) = @_;
4544   EXCUSE: {
4545         my @e;
4546         exists $self->{'build_dir'} and push @e,
4547             "Is already unwrapped into directory $self->{'build_dir'}";
4548         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
4549     }
4550     my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
4551
4552     #
4553     # Get the file on local disk
4554     #
4555
4556     my($local_file);
4557     my($local_wanted) =
4558         File::Spec->catfile(
4559                             $CPAN::Config->{keep_source_where},
4560                             "authors",
4561                             "id",
4562                             split(/\//,$self->id)
4563                            );
4564
4565     $self->debug("Doing localize") if $CPAN::DEBUG;
4566     unless ($local_file =
4567             CPAN::FTP->localize("authors/id/$self->{ID}",
4568                                 $local_wanted)) {
4569         my $note = "";
4570         if ($CPAN::Index::DATE_OF_02) {
4571             $note = "Note: Current database in memory was generated ".
4572                 "on $CPAN::Index::DATE_OF_02\n";
4573         }
4574         $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
4575     }
4576     $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
4577     $self->{localfile} = $local_file;
4578     return if $CPAN::Signal;
4579
4580     #
4581     # Check integrity
4582     #
4583     if ($CPAN::META->has_inst("Digest::SHA")) {
4584         $self->debug("Digest::SHA is installed, verifying");
4585         $self->verifyCHECKSUM;
4586     } else {
4587         $self->debug("Digest::SHA is NOT installed");
4588     }
4589     return if $CPAN::Signal;
4590
4591     #
4592     # Create a clean room and go there
4593     #
4594     $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
4595     my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
4596     $self->safe_chdir($builddir);
4597     $self->debug("Removing tmp") if $CPAN::DEBUG;
4598     File::Path::rmtree("tmp");
4599     unless (mkdir "tmp", 0755) {
4600         $CPAN::Frontend->unrecoverable_error(<<EOF);
4601 Couldn't mkdir '$builddir/tmp': $!
4602
4603 Cannot continue: Please find the reason why I cannot make the
4604 directory
4605 $builddir/tmp
4606 and fix the problem, then retry.
4607
4608 EOF
4609     }
4610     if ($CPAN::Signal){
4611         $self->safe_chdir($sub_wd);
4612         return;
4613     }
4614     $self->safe_chdir("tmp");
4615
4616     #
4617     # Unpack the goods
4618     #
4619     $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
4620     my $ct = CPAN::Tarzip->new($local_file);
4621     if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i){
4622         $self->{was_uncompressed}++ unless $ct->gtest();
4623         $self->untar_me($ct);
4624     } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
4625         $self->unzip_me($ct);
4626     } else {
4627         $self->{was_uncompressed}++ unless $ct->gtest();
4628         $self->debug("calling pm2dir for local_file[$local_file]")
4629           if $CPAN::DEBUG;
4630         $local_file = $self->handle_singlefile($local_file);
4631 #    } else {
4632 #       $self->{archived} = "NO";
4633 #        $self->safe_chdir($sub_wd);
4634 #        return;
4635     }
4636
4637     # we are still in the tmp directory!
4638     # Let's check if the package has its own directory.
4639     my $dh = DirHandle->new(File::Spec->curdir)
4640         or Carp::croak("Couldn't opendir .: $!");
4641     my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
4642     $dh->close;
4643     my ($distdir,$packagedir);
4644     if (@readdir == 1 && -d $readdir[0]) {
4645         $distdir = $readdir[0];
4646         $packagedir = File::Spec->catdir($builddir,$distdir);
4647         $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
4648             if $CPAN::DEBUG;
4649         -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
4650                                                     "$packagedir\n");
4651         File::Path::rmtree($packagedir);
4652         unless (File::Copy::move($distdir,$packagedir)) {
4653             $CPAN::Frontend->unrecoverable_error(<<EOF);
4654 Couldn't move '$distdir' to '$packagedir': $!
4655
4656 Cannot continue: Please find the reason why I cannot move
4657 $builddir/tmp/$distdir
4658 to
4659 $packagedir
4660 and fix the problem, then retry
4661
4662 EOF
4663         }
4664         $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
4665                              $distdir,
4666                              $packagedir,
4667                              -e $packagedir,
4668                              -d $packagedir,
4669                             )) if $CPAN::DEBUG;
4670     } else {
4671         my $userid = $self->cpan_userid;
4672         unless ($userid) {
4673             CPAN->debug("no userid? self[$self]");
4674             $userid = "anon";
4675         }
4676         my $pragmatic_dir = $userid . '000';
4677         $pragmatic_dir =~ s/\W_//g;
4678         $pragmatic_dir++ while -d "../$pragmatic_dir";
4679         $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
4680         $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
4681         File::Path::mkpath($packagedir);
4682         my($f);
4683         for $f (@readdir) { # is already without "." and ".."
4684             my $to = File::Spec->catdir($packagedir,$f);
4685             File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
4686         }
4687     }
4688     if ($CPAN::Signal){
4689         $self->safe_chdir($sub_wd);
4690         return;
4691     }
4692
4693     $self->{'build_dir'} = $packagedir;
4694     $self->safe_chdir($builddir);
4695     File::Path::rmtree("tmp");
4696
4697     $self->safe_chdir($packagedir);
4698     if ($CPAN::Config->{check_sigs}) {
4699         if ($CPAN::META->has_inst("Module::Signature")) {
4700             if (-f "SIGNATURE") {
4701                 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
4702                 my $rv = Module::Signature::verify();
4703                 if ($rv != Module::Signature::SIGNATURE_OK() and
4704                     $rv != Module::Signature::SIGNATURE_MISSING()) {
4705                     $CPAN::Frontend->myprint(
4706                                              qq{\nSignature invalid for }.
4707                                              qq{distribution file. }.
4708                                              qq{Please investigate.\n\n}.
4709                                              $self->as_string,
4710                                              $CPAN::META->instance(
4711                                                                    'CPAN::Author',
4712                                                                    $self->cpan_userid,
4713                                                                   )->as_string
4714                                             );
4715
4716                     my $wrap =
4717                         sprintf(qq{I'd recommend removing %s. Its signature
4718 is invalid. Maybe you have configured your 'urllist' with
4719 a bad URL. Please check this array with 'o conf urllist', and
4720 retry. For more information, try opening a subshell with
4721   look %s
4722 and there run
4723   cpansign -v
4724 },
4725                                 $self->{localfile},
4726                                 $self->pretty_id,
4727                                );
4728                     $self->{signature_verify} = CPAN::Distrostatus->new("NO");
4729                     $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
4730                     $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
4731                 } else {
4732                     $self->{signature_verify} = CPAN::Distrostatus->new("YES");
4733                     $self->debug("Module::Signature has verified") if $CPAN::DEBUG;
4734                 }
4735             } else {
4736                 $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n});
4737             }
4738         } else {
4739             $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
4740         }
4741     }
4742     $self->safe_chdir($builddir);
4743     return if $CPAN::Signal;
4744
4745
4746     my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
4747     my($mpl_exists) = -f $mpl;
4748     unless ($mpl_exists) {
4749         # NFS has been reported to have racing problems after the
4750         # renaming of a directory in some environments.
4751         # This trick helps.
4752         $CPAN::Frontend->mysleep(1);
4753         my $mpldh = DirHandle->new($packagedir)
4754             or Carp::croak("Couldn't opendir $packagedir: $!");
4755         $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
4756         $mpldh->close;
4757     }
4758     my $prefer_installer = "eumm"; # eumm|mb
4759     if (-f File::Spec->catfile($packagedir,"Build.PL")) {
4760         if ($mpl_exists) { # they *can* choose
4761             if ($CPAN::META->has_inst("Module::Build")) {
4762                 $prefer_installer = $CPAN::Config->{prefer_installer};
4763             }
4764         } else {
4765             $prefer_installer = "mb";
4766         }
4767     }
4768     if (lc($prefer_installer) eq "mb") {
4769         $self->{modulebuild} = 1;
4770     } elsif (! $mpl_exists) {
4771         $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
4772                              $mpl,
4773                              CPAN::anycwd(),
4774                             )) if $CPAN::DEBUG;
4775         my($configure) = File::Spec->catfile($packagedir,"Configure");
4776         if (-f $configure) {
4777             # do we have anything to do?
4778             $self->{'configure'} = $configure;
4779         } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
4780             $CPAN::Frontend->mywarn(qq{
4781 Package comes with a Makefile and without a Makefile.PL.
4782 We\'ll try to build it with that Makefile then.
4783 });
4784             $self->{writemakefile} = CPAN::Distrostatus->new("YES");
4785             $CPAN::Frontend->mysleep(2);
4786         } else {
4787             my $cf = $self->called_for || "unknown";
4788             if ($cf =~ m|/|) {
4789                 $cf =~ s|.*/||;
4790                 $cf =~ s|\W.*||;
4791             }
4792             $cf =~ s|[/\\:]||g; # risk of filesystem damage
4793             $cf = "unknown" unless length($cf);
4794             $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
4795   (The test -f "$mpl" returned false.)
4796   Writing one on our own (setting NAME to $cf)\a\n});
4797             $self->{had_no_makefile_pl}++;
4798             $CPAN::Frontend->mysleep(3);
4799
4800             # Writing our own Makefile.PL
4801
4802             my $script = "";
4803             if ($self->{archived} eq "maybe_pl"){
4804                 my $fh = FileHandle->new;
4805                 my $script_file = File::Spec->catfile($packagedir,$local_file);
4806                 $fh->open($script_file)
4807                   or Carp::croak("Could not open $script_file: $!");
4808                 local $/ = "\n";
4809                 # name parsen und prereq
4810                 my($state) = "poddir";
4811                 my($name, $prereq) = ("", "");
4812                 while (<$fh>){
4813                     if ($state eq "poddir" && /^=head\d\s+(\S+)/) {
4814                         if ($1 eq 'NAME') {
4815                             $state = "name";
4816                         } elsif ($1 eq 'PREREQUISITES') {
4817                             $state = "prereq";
4818                         }
4819                     } elsif ($state =~ m{^(name|prereq)$}) {
4820                         if (/^=/) {
4821                             $state = "poddir";
4822                         } elsif (/^\s*$/) {
4823                             # nop
4824                         } elsif ($state eq "name") {
4825                             if ($name eq "") {
4826                                 ($name) = /^(\S+)/;
4827                                 $state = "poddir";
4828                             }
4829                         } elsif ($state eq "prereq") {
4830                             $prereq .= $_;
4831                         }
4832                     } elsif (/^=cut\b/) {
4833                         last;
4834                     }
4835                 }
4836                 $fh->close;
4837
4838                 for ($name) {
4839                     s{.*<}{}; # strip X<...>
4840                     s{>.*}{};
4841                 }
4842                 chomp $prereq;
4843                 $prereq = join " ", split /\s+/, $prereq;
4844                 my($PREREQ_PM) = join("\n", map {
4845                     s{.*<}{}; # strip X<...>
4846                     s{>.*}{};
4847                     if (/[\s\'\"]/) { # prose?
4848                     } else {
4849                         s/[^\w:]$//; # period?
4850                         " "x28 . "'$_' => 0,";
4851                     }
4852                 } split /\s*,\s*/, $prereq);
4853
4854                 $script = "
4855               EXE_FILES => ['$name'],
4856               PREREQ_PM => {
4857 $PREREQ_PM
4858                            },
4859 ";
4860
4861                 my $to_file = File::Spec->catfile($packagedir, $name);
4862                 rename $script_file, $to_file
4863                   or die "Can't rename $script_file to $to_file: $!";
4864             }
4865
4866             my $fh = FileHandle->new;
4867             $fh->open(">$mpl")
4868                 or Carp::croak("Could not open >$mpl: $!");
4869             $fh->print(
4870 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
4871 # because there was no Makefile.PL supplied.
4872 # Autogenerated on: }.scalar localtime().qq{
4873
4874 use ExtUtils::MakeMaker;
4875 WriteMakefile(
4876               NAME => q[$cf],$script
4877              );
4878 });
4879             $fh->close;
4880         }
4881     }
4882
4883     return $self;
4884 }
4885
4886 # CPAN::Distribution::untar_me ;
4887 sub untar_me {
4888     my($self,$ct) = @_;
4889     $self->{archived} = "tar";
4890     if ($ct->untar()) {
4891         $self->{unwrapped} = "YES";
4892     } else {
4893         $self->{unwrapped} = "NO";
4894     }
4895 }
4896
4897 # CPAN::Distribution::unzip_me ;
4898 sub unzip_me {
4899     my($self,$ct) = @_;
4900     $self->{archived} = "zip";
4901     if ($ct->unzip()) {
4902         $self->{unwrapped} = "YES";
4903     } else {
4904         $self->{unwrapped} = "NO";
4905     }
4906     return;
4907 }
4908
4909 sub handle_singlefile {
4910     my($self,$local_file) = @_;
4911
4912     if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ){
4913         $self->{archived} = "pm";
4914     } else {
4915         $self->{archived} = "maybe_pl";
4916     }
4917
4918     my $to = File::Basename::basename($local_file);
4919     if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
4920         if (CPAN::Tarzip->new($local_file)->gunzip($to)) {
4921             $self->{unwrapped} = "YES";
4922         } else {
4923             $self->{unwrapped} = "NO";
4924         }
4925     } else {
4926         File::Copy::cp($local_file,".");
4927         $self->{unwrapped} = "YES";
4928     }
4929     return $to;
4930 }
4931
4932 #-> sub CPAN::Distribution::new ;
4933 sub new {
4934     my($class,%att) = @_;
4935
4936     # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
4937
4938     my $this = { %att };
4939     return bless $this, $class;
4940 }
4941
4942 #-> sub CPAN::Distribution::look ;
4943 sub look {
4944     my($self) = @_;
4945
4946     if ($^O eq 'MacOS') {
4947       $self->Mac::BuildTools::look;
4948       return;
4949     }
4950
4951     if (  $CPAN::Config->{'shell'} ) {
4952         $CPAN::Frontend->myprint(qq{
4953 Trying to open a subshell in the build directory...
4954 });
4955     } else {
4956         $CPAN::Frontend->myprint(qq{
4957 Your configuration does not define a value for subshells.
4958 Please define it with "o conf shell <your shell>"
4959 });
4960         return;
4961     }
4962     my $dist = $self->id;
4963     my $dir;
4964     unless ($dir = $self->dir) {
4965         $self->get;
4966     }
4967     unless ($dir ||= $self->dir) {
4968         $CPAN::Frontend->mywarn(qq{
4969 Could not determine which directory to use for looking at $dist.
4970 });
4971         return;
4972     }
4973     my $pwd  = CPAN::anycwd();
4974     $self->safe_chdir($dir);
4975     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4976     {
4977         local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
4978         $ENV{CPAN_SHELL_LEVEL} += 1;
4979         my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'});
4980         unless (system($shell) == 0) {
4981             my $code = $? >> 8;
4982             $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
4983         }
4984     }
4985     $self->safe_chdir($pwd);
4986 }
4987
4988 # CPAN::Distribution::cvs_import ;
4989 sub cvs_import {
4990     my($self) = @_;
4991     $self->get;
4992     my $dir = $self->dir;
4993
4994     my $package = $self->called_for;
4995     my $module = $CPAN::META->instance('CPAN::Module', $package);
4996     my $version = $module->cpan_version;
4997
4998     my $userid = $self->cpan_userid;
4999
5000     my $cvs_dir = (split /\//, $dir)[-1];
5001     $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
5002     my $cvs_root =
5003       $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
5004     my $cvs_site_perl =
5005       $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
5006     if ($cvs_site_perl) {
5007         $cvs_dir = "$cvs_site_perl/$cvs_dir";
5008     }
5009     my $cvs_log = qq{"imported $package $version sources"};
5010     $version =~ s/\./_/g;
5011     # XXX cvs: undocumented and unclear how it was meant to work
5012     my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
5013                "$cvs_dir", $userid, "v$version");
5014
5015     my $pwd  = CPAN::anycwd();
5016     chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
5017
5018     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
5019
5020     $CPAN::Frontend->myprint(qq{@cmd\n});
5021     system(@cmd) == 0 or
5022     # XXX cvs
5023         $CPAN::Frontend->mydie("cvs import failed");
5024     chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
5025 }
5026
5027 #-> sub CPAN::Distribution::readme ;
5028 sub readme {
5029     my($self) = @_;
5030     my($dist) = $self->id;
5031     my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
5032     $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
5033     my($local_file);
5034     my($local_wanted) =
5035          File::Spec->catfile(
5036                              $CPAN::Config->{keep_source_where},
5037                              "authors",
5038                              "id",
5039                              split(/\//,"$sans.readme"),
5040                             );
5041     $self->debug("Doing localize") if $CPAN::DEBUG;
5042     $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
5043                                       $local_wanted)
5044         or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
5045
5046     if ($^O eq 'MacOS') {
5047         Mac::BuildTools::launch_file($local_file);
5048         return;
5049     }
5050
5051     my $fh_pager = FileHandle->new;
5052     local($SIG{PIPE}) = "IGNORE";
5053     my $pager = $CPAN::Config->{'pager'} || "cat";
5054     $fh_pager->open("|$pager")
5055         or die "Could not open pager $pager\: $!";
5056     my $fh_readme = FileHandle->new;
5057     $fh_readme->open($local_file)
5058         or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
5059     $CPAN::Frontend->myprint(qq{
5060 Displaying file
5061   $local_file
5062 with pager "$pager"
5063 });
5064     $fh_pager->print(<$fh_readme>);
5065     $fh_pager->close;
5066 }
5067
5068 #-> sub CPAN::Distribution::verifyCHECKSUM ;
5069 sub verifyCHECKSUM {
5070     my($self) = @_;
5071   EXCUSE: {
5072         my @e;
5073         $self->{CHECKSUM_STATUS} ||= "";
5074         $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
5075         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
5076     }
5077     my($lc_want,$lc_file,@local,$basename);
5078     @local = split(/\//,$self->id);
5079     pop @local;
5080     push @local, "CHECKSUMS";
5081     $lc_want =
5082         File::Spec->catfile($CPAN::Config->{keep_source_where},
5083                             "authors", "id", @local);
5084     local($") = "/";
5085     if (my $size = -s $lc_want) {
5086         $self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG;
5087         if ($self->CHECKSUM_check_file($lc_want,1)) {
5088             return $self->{CHECKSUM_STATUS} = "OK";
5089         }
5090     }
5091     $lc_file = CPAN::FTP->localize("authors/id/@local",
5092                                    $lc_want,1);
5093     unless ($lc_file) {
5094         $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
5095         $local[-1] .= ".gz";
5096         $lc_file = CPAN::FTP->localize("authors/id/@local",
5097                                        "$lc_want.gz",1);
5098         if ($lc_file) {
5099             $lc_file =~ s/\.gz(?!\n)\Z//;
5100             CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file);
5101         } else {
5102             return;
5103         }
5104     }
5105     if ($self->CHECKSUM_check_file($lc_file)) {
5106         return $self->{CHECKSUM_STATUS} = "OK";
5107     }
5108 }
5109
5110 #-> sub CPAN::Distribution::SIG_check_file ;
5111 sub SIG_check_file {
5112     my($self,$chk_file) = @_;
5113     my $rv = eval { Module::Signature::_verify($chk_file) };
5114
5115     if ($rv == Module::Signature::SIGNATURE_OK()) {
5116         $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
5117         return $self->{SIG_STATUS} = "OK";
5118     } else {
5119         $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
5120                                  qq{distribution file. }.
5121                                  qq{Please investigate.\n\n}.
5122                                  $self->as_string,
5123                                 $CPAN::META->instance(
5124                                                         'CPAN::Author',
5125                                                         $self->cpan_userid
5126                                                         )->as_string);
5127
5128         my $wrap = qq{I\'d recommend removing $chk_file. Its signature
5129 is invalid. Maybe you have configured your 'urllist' with
5130 a bad URL. Please check this array with 'o conf urllist', and
5131 retry.};
5132
5133         $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
5134     }
5135 }
5136
5137 #-> sub CPAN::Distribution::CHECKSUM_check_file ;
5138
5139 # sloppy is 1 when we have an old checksums file that maybe is good
5140 # enough
5141
5142 sub CHECKSUM_check_file {
5143     my($self,$chk_file,$sloppy) = @_;
5144     my($cksum,$file,$basename);
5145
5146     $sloppy ||= 0;
5147     $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG;
5148     if ($CPAN::Config->{check_sigs}) {
5149         if ($CPAN::META->has_inst("Module::Signature") and Module::Signature->VERSION >= 0.26) {
5150             $self->debug("Module::Signature is installed, verifying");
5151             $self->SIG_check_file($chk_file);
5152         } else {
5153             $self->debug("Module::Signature is NOT installed");
5154         }
5155     }
5156
5157     $file = $self->{localfile};
5158     $basename = File::Basename::basename($file);
5159     my $fh = FileHandle->new;
5160     if (open $fh, $chk_file){
5161         local($/);
5162         my $eval = <$fh>;
5163         $eval =~ s/\015?\012/\n/g;
5164         close $fh;
5165         my($comp) = Safe->new();
5166         $cksum = $comp->reval($eval);
5167         if ($@) {
5168             rename $chk_file, "$chk_file.bad";
5169             Carp::confess($@) if $@;
5170         }
5171     } else {
5172         Carp::carp "Could not open $chk_file for reading";
5173     }
5174
5175     if (! ref $cksum or ref $cksum ne "HASH") {
5176         $CPAN::Frontend->mywarn(qq{
5177 Warning: checksum file '$chk_file' broken.
5178
5179 When trying to read that file I expected to get a hash reference
5180 for further processing, but got garbage instead.
5181 });
5182         my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
5183         $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
5184         $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken";
5185         return;
5186     } elsif (exists $cksum->{$basename}{sha256}) {
5187         $self->debug("Found checksum for $basename:" .
5188                      "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
5189
5190         open($fh, $file);
5191         binmode $fh;
5192         my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
5193         $fh->close;
5194         $fh = CPAN::Tarzip->TIEHANDLE($file);
5195
5196         unless ($eq) {
5197           my $dg = Digest::SHA->new(256);
5198           my($data,$ref);
5199           $ref = \$data;
5200           while ($fh->READ($ref, 4096) > 0){
5201             $dg->add($data);
5202           }
5203           my $hexdigest = $dg->hexdigest;
5204           $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
5205         }
5206
5207         if ($eq) {
5208           $CPAN::Frontend->myprint("Checksum for $file ok\n");
5209           return $self->{CHECKSUM_STATUS} = "OK";
5210         } else {
5211             $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
5212                                      qq{distribution file. }.
5213                                      qq{Please investigate.\n\n}.
5214                                      $self->as_string,
5215                                      $CPAN::META->instance(
5216                                                            'CPAN::Author',
5217                                                            $self->cpan_userid
5218                                                           )->as_string);
5219
5220             my $wrap = qq{I\'d recommend removing $file. Its
5221 checksum is incorrect. Maybe you have configured your 'urllist' with
5222 a bad URL. Please check this array with 'o conf urllist', and
5223 retry.};
5224
5225             $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
5226
5227             # former versions just returned here but this seems a
5228             # serious threat that deserves a die
5229
5230             # $CPAN::Frontend->myprint("\n\n");
5231             # sleep 3;
5232             # return;
5233         }
5234         # close $fh if fileno($fh);
5235     } else {
5236         return if $sloppy;
5237         unless ($self->{CHECKSUM_STATUS}) {
5238             $CPAN::Frontend->mywarn(qq{
5239 Warning: No checksum for $basename in $chk_file.
5240
5241 The cause for this may be that the file is very new and the checksum
5242 has not yet been calculated, but it may also be that something is
5243 going awry right now.
5244 });
5245             my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes");
5246             $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
5247         }
5248         $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file";
5249         return;
5250     }
5251 }
5252
5253 #-> sub CPAN::Distribution::eq_CHECKSUM ;
5254 sub eq_CHECKSUM {
5255     my($self,$fh,$expect) = @_;
5256     if ($CPAN::META->has_inst("Digest::SHA")) {
5257         my $dg = Digest::SHA->new(256);
5258         my($data);
5259         while (read($fh, $data, 4096)){
5260             $dg->add($data);
5261         }
5262         my $hexdigest = $dg->hexdigest;
5263         # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
5264         return $hexdigest eq $expect;
5265     }
5266     return 1;
5267 }
5268
5269 #-> sub CPAN::Distribution::force ;
5270
5271 # Both CPAN::Modules and CPAN::Distributions know if "force" is in
5272 # effect by autoinspection, not by inspecting a global variable. One
5273 # of the reason why this was chosen to work that way was the treatment
5274 # of dependencies. They should not automatically inherit the force
5275 # status. But this has the downside that ^C and die() will return to
5276 # the prompt but will not be able to reset the force_update
5277 # attributes. We try to correct for it currently in the read_metadata
5278 # routine, and immediately before we check for a Signal. I hope this
5279 # works out in one of v1.57_53ff
5280
5281 # "Force get forgets previous error conditions"
5282
5283 #-> sub CPAN::Distribution::force ;
5284 sub force {
5285   my($self, $method) = @_;
5286   for my $att (qw(
5287   CHECKSUM_STATUS archived build_dir localfile make install unwrapped
5288   writemakefile modulebuild make_test signature_verify
5289  )) {
5290     delete $self->{$att};
5291   }
5292   if ($method && $method =~ /make|test|install/) {
5293     $self->{"force_update"}++; # name should probably have been force_install
5294   }
5295 }
5296
5297 sub notest {
5298   my($self, $method) = @_;
5299   # warn "XDEBUG: set notest for $self $method";
5300   $self->{"notest"}++; # name should probably have been force_install
5301 }
5302
5303 sub unnotest {
5304   my($self) = @_;
5305   # warn "XDEBUG: deleting notest";
5306   delete $self->{'notest'};
5307 }
5308
5309 #-> sub CPAN::Distribution::unforce ;
5310 sub unforce {
5311   my($self) = @_;
5312   delete $self->{'force_update'};
5313 }
5314
5315 #-> sub CPAN::Distribution::isa_perl ;
5316 sub isa_perl {
5317   my($self) = @_;
5318   my $file = File::Basename::basename($self->id);
5319   if ($file =~ m{ ^ perl
5320                   -?
5321                   (5)
5322                   ([._-])
5323                   (
5324                    \d{3}(_[0-4][0-9])?
5325                    |
5326                    \d+\.\d+
5327                   )
5328                   \.tar[._-]gz
5329                   (?!\n)\Z
5330                 }xs){
5331     return "$1.$3";
5332   } elsif ($self->cpan_comment
5333            &&
5334            $self->cpan_comment =~ /isa_perl\(.+?\)/){
5335     return $1;
5336   }
5337 }
5338
5339
5340 #-> sub CPAN::Distribution::perl ;
5341 sub perl {
5342     my ($self) = @_;
5343     if (! $self) {
5344         use Carp qw(carp);
5345         carp __PACKAGE__ . "::perl was called without parameters.";
5346     }
5347     return CPAN::HandleConfig->safe_quote($CPAN::Perl);
5348 }
5349
5350
5351 #-> sub CPAN::Distribution::make ;
5352 sub make {
5353     my($self) = @_;
5354     my $make = $self->{modulebuild} ? "Build" : "make";
5355     $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
5356     # Emergency brake if they said install Pippi and get newest perl
5357     if ($self->isa_perl) {
5358       if (
5359           $self->called_for ne $self->id &&
5360           ! $self->{force_update}
5361          ) {
5362         # if we die here, we break bundles
5363         $CPAN::Frontend->mywarn(sprintf qq{
5364 The most recent version "%s" of the module "%s"
5365 comes with the current version of perl (%s).
5366 I\'ll build that only if you ask for something like
5367     force install %s
5368 or
5369     install %s
5370 },
5371                                $CPAN::META->instance(
5372                                                      'CPAN::Module',
5373                                                      $self->called_for
5374                                                     )->cpan_version,
5375                                $self->called_for,
5376                                $self->isa_perl,
5377                                $self->called_for,
5378                                $self->id);
5379         $self->{make} = CPAN::Distrostatus->new("NO isa perl");
5380         $CPAN::Frontend->mysleep(1);
5381         return;
5382       }
5383     }
5384     $self->get;
5385     if ($CPAN::Signal){
5386       delete $self->{force_update};
5387       return;
5388     }
5389   EXCUSE: {
5390         my @e;
5391         !$self->{archived} || $self->{archived} eq "NO" and push @e,
5392         "Is neither a tar nor a zip archive.";
5393
5394         !$self->{unwrapped} || $self->{unwrapped} eq "NO" and push @e,
5395         "Had problems unarchiving. Please build manually";
5396
5397         unless ($self->{force_update}) {
5398             exists $self->{signature_verify} and (
5399                          $self->{signature_verify}->can("failed") ?
5400                          $self->{signature_verify}->failed :
5401                          $self->{signature_verify} =~ /^NO/
5402                         )
5403                 and push @e, "Did not pass the signature test.";
5404         }
5405
5406         if (exists $self->{writemakefile} &&
5407             (
5408              $self->{writemakefile}->can("failed") ?
5409              $self->{writemakefile}->failed :
5410              $self->{writemakefile} =~ /^NO/
5411             )) {
5412             # XXX maybe a retry would be in order?
5413             my $err = $self->{writemakefile}->can("text") ?
5414                 $self->{writemakefile}->text :
5415                     $self->{writemakefile};
5416             $err =~ s/^NO\s*//;
5417             $err ||= "Had some problem writing Makefile";
5418             $err .= ", won't make";
5419             push @e, $err;
5420         }
5421
5422         defined $self->{make} and push @e,
5423             "Has already been processed within this session";
5424
5425         if (exists $self->{later} and length($self->{later})) {
5426             if ($self->unsat_prereq) {
5427                 push @e, $self->{later};
5428 # RT ticket 18438 raises doubts if the deletion of {later} is valid.
5429 # YAML-0.53 triggered the later hodge-podge here, but my margin notes
5430 # are not sufficient to be sure if we really must/may do the delete
5431 # here. SO I accept the suggested patch for now. If we trigger a bug
5432 # again, I must go into deep contemplation about the {later} flag.
5433
5434 #            } else {
5435 #                delete $self->{later};
5436             }
5437         }
5438
5439         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
5440     }
5441     if ($CPAN::Signal){
5442       delete $self->{force_update};
5443       return;
5444     }
5445     $CPAN::Frontend->myprint("\n  CPAN.pm: Going to build ".$self->id."\n\n");
5446     my $builddir = $self->dir or
5447         $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
5448     chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
5449     $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
5450
5451     if ($^O eq 'MacOS') {
5452         Mac::BuildTools::make($self);
5453         return;
5454     }
5455
5456     my $system;
5457     if ($self->{'configure'}) {
5458         $system = $self->{'configure'};
5459     } elsif ($self->{modulebuild}) {
5460         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
5461         $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}";
5462     } else {
5463         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
5464         my $switch = "";
5465 # This needs a handler that can be turned on or off:
5466 #       $switch = "-MExtUtils::MakeMaker ".
5467 #           "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
5468 #           if $] > 5.00310;
5469         $system = sprintf("%s%s Makefile.PL%s",
5470                           $perl,
5471                           $switch ? " $switch" : "",
5472                           $CPAN::Config->{makepl_arg} ? " $CPAN::Config->{makepl_arg}" : "",
5473                          );
5474     }
5475     unless (exists $self->{writemakefile}) {
5476         local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
5477         my($ret,$pid);
5478         $@ = "";
5479         my $go_via_alarm;
5480         if ($CPAN::Config->{inactivity_timeout}) {
5481             require Config;
5482             if ($Config::Config{d_alarm}
5483                 &&
5484                 $Config::Config{d_alarm} eq "define"
5485                ) {
5486                 $go_via_alarm++
5487             } else {
5488                 $CPAN::Frontend->mywarn("Warning: you have configured the config ".
5489                                         "variable 'inactivity_timeout' to ".
5490                                         "'$CPAN::Config->{inactivity_timeout}'. But ".
5491                                         "on this machine the system call 'alarm' ".
5492                                         "isn't available. This means that we cannot ".
5493                                         "provide the feature of intercepting long ".
5494                                         "waiting code and will turn this feature off.\n"
5495                                        );
5496                 $CPAN::Config->{inactivity_timeout} = 0;
5497             }
5498         }
5499         if ($go_via_alarm) {
5500             eval {
5501                 alarm $CPAN::Config->{inactivity_timeout};
5502                 local $SIG{CHLD}; # = sub { wait };
5503                 if (defined($pid = fork)) {
5504                     if ($pid) { #parent
5505                         # wait;
5506                         waitpid $pid, 0;
5507                     } else {    #child
5508                         # note, this exec isn't necessary if
5509                         # inactivity_timeout is 0. On the Mac I'd
5510                         # suggest, we set it always to 0.
5511                         exec $system;
5512                     }
5513                 } else {
5514                     $CPAN::Frontend->myprint("Cannot fork: $!");
5515                     return;
5516                 }
5517             };
5518             alarm 0;
5519             if ($@){
5520                 kill 9, $pid;
5521                 waitpid $pid, 0;
5522                 my $err = "$@";
5523                 $CPAN::Frontend->myprint($err);
5524                 $self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
5525                 $@ = "";
5526                 return;
5527             }
5528         } else {
5529           $ret = system($system);
5530           if ($ret != 0) {
5531             $self->{writemakefile} = CPAN::Distrostatus
5532                 ->new("NO '$system' returned status $ret");
5533             $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
5534             return;
5535           }
5536         }
5537         if (-f "Makefile" || -f "Build") {
5538           $self->{writemakefile} = CPAN::Distrostatus->new("YES");
5539           delete $self->{make_clean}; # if cleaned before, enable next
5540         } else {
5541           $self->{writemakefile} = CPAN::Distrostatus
5542               ->new(qq{NO -- Unknown reason.});
5543         }
5544     }
5545     if ($CPAN::Signal){
5546       delete $self->{force_update};
5547       return;
5548     }
5549     if (my @prereq = $self->unsat_prereq){
5550       return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
5551     }
5552     if ($self->{modulebuild}) {
5553         unless (-f "Build") {
5554             my $cwd = Cwd::cwd;
5555             $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
5556                                     " in cwd[$cwd]. Danger, Will Robinson!");
5557             $CPAN::Frontend->mysleep(5);
5558         }
5559         $system = sprintf "%s %s", $self->_build_command(), $CPAN::Config->{mbuild_arg};
5560     } else {
5561         $system = join " ", $self->_make_command(), $CPAN::Config->{make_arg};
5562     }
5563     if (system($system) == 0) {
5564          $CPAN::Frontend->myprint("  $system -- OK\n");
5565          $self->{make} = CPAN::Distrostatus->new("YES");
5566     } else {
5567          $self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
5568          $self->{make} = CPAN::Distrostatus->new("NO");
5569          $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
5570     }
5571 }
5572
5573 sub _make_command {
5574     my ($self) = @_;
5575     if ($self) {
5576         return
5577           CPAN::HandleConfig
5578                 ->safe_quote(
5579                              $CPAN::Config->{make} || $Config::Config{make} || 'make'
5580                             );
5581     } else {
5582         # Old style call, without object. Deprecated
5583         Carp::confess("CPAN::_make_command() used as function. Don't Do That.");
5584         return
5585           safe_quote(undef, $CPAN::Config->{make} || $Config::Config{make} || 'make');
5586     }
5587 }
5588
5589 #-> sub CPAN::Distribution::follow_prereqs ;
5590 sub follow_prereqs {
5591     my($self) = shift;
5592     my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
5593     return unless @prereq_tuples;
5594     my @prereq = map { $_->[0] } @prereq_tuples;
5595     my $id = $self->id;
5596     my %map = (
5597                b => "build_requires",
5598                r => "requires",
5599                c => "commandline",
5600               );
5601     $CPAN::Frontend->
5602         myprint("---- Unsatisfied dependencies detected ".
5603                 "during [$id] -----\n".
5604                 join("", map {"    $_->[0] \[$map{$_->[1]}]\n"} @prereq_tuples),
5605                );
5606     my $follow = 0;
5607     if ($CPAN::Config->{prerequisites_policy} eq "follow") {
5608         $follow = 1;
5609     } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
5610         my $answer = CPAN::Shell::colorable_makemaker_prompt(
5611 "Shall I follow them and prepend them to the queue
5612 of modules we are processing right now?", "yes");
5613         $follow = $answer =~ /^\s*y/i;
5614     } else {
5615         local($") = ", ";
5616         $CPAN::Frontend->
5617             myprint("  Ignoring dependencies on modules @prereq\n");
5618     }
5619     if ($follow) {
5620         # color them as dirty
5621         for my $p (@prereq) {
5622             # warn "calling color_cmd_tmps(0,1)";
5623             CPAN::Shell->expandany($p)->color_cmd_tmps(0,1);
5624         }
5625         # queue them and re-queue yourself
5626         CPAN::Queue->jumpqueue([$id,$self->{reqtype}],
5627                                reverse @prereq_tuples);
5628         $self->{later} = "Delayed until after prerequisites";
5629         return 1; # signal success to the queuerunner
5630     }
5631 }
5632
5633 #-> sub CPAN::Distribution::unsat_prereq ;
5634 sub unsat_prereq {
5635     my($self) = @_;
5636     my $prereq_pm = $self->prereq_pm or return;
5637     my(@need);
5638     my %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}});
5639   NEED: while (my($need_module, $need_version) = each %merged) {
5640         my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
5641         # we were too demanding:
5642         next if $nmo->uptodate;
5643
5644         # if they have not specified a version, we accept any installed one
5645         if (not defined $need_version or
5646            $need_version eq "0" or
5647            $need_version eq "undef") {
5648             next if defined $nmo->inst_file;
5649         }
5650
5651         # We only want to install prereqs if either they're not installed
5652         # or if the installed version is too old. We cannot omit this
5653         # check, because if 'force' is in effect, nobody else will check.
5654         if (defined $nmo->inst_file) {
5655             my(@all_requirements) = split /\s*,\s*/, $need_version;
5656             local($^W) = 0;
5657             my $ok = 0;
5658           RQ: for my $rq (@all_requirements) {
5659                 if ($rq =~ s|>=\s*||) {
5660                 } elsif ($rq =~ s|>\s*||) {
5661                     # 2005-12: one user
5662                     if (CPAN::Version->vgt($nmo->inst_version,$rq)){
5663                         $ok++;
5664                     }
5665                     next RQ;
5666                 } elsif ($rq =~ s|!=\s*||) {
5667                     # 2005-12: no user
5668                     if (CPAN::Version->vcmp($nmo->inst_version,$rq)){
5669                         $ok++;
5670                         next RQ;
5671                     } else {
5672                         last RQ;
5673                     }
5674                 } elsif ($rq =~ m|<=?\s*|) {
5675                     # 2005-12: no user
5676                     $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])");
5677                     $ok++;
5678                     next RQ;
5679                 }
5680                 if (! CPAN::Version->vgt($rq, $nmo->inst_version)){
5681                     $ok++;
5682                 }
5683                 CPAN->debug(sprintf "id[%s]inst_file[%s]inst_version[%s]rq[%s]ok[%d]",
5684                             $nmo->id,
5685                             $nmo->inst_file,
5686                             $nmo->inst_version,
5687                             CPAN::Version->readable($rq),
5688                             $ok,
5689                            ) if $CPAN::DEBUG;
5690             }
5691             next NEED if $ok == @all_requirements;
5692         }
5693
5694         if ($self->{sponsored_mods}{$need_module}++){
5695             # We have already sponsored it and for some reason it's still
5696             # not available. So we do nothing. Or what should we do?
5697             # if we push it again, we have a potential infinite loop
5698             next;
5699         }
5700         my $needed_as = exists $prereq_pm->{requires}{$need_module} ? "r" : "b";
5701         push @need, [$need_module,$needed_as];
5702     }
5703     @need;
5704 }
5705
5706 #-> sub CPAN::Distribution::read_yaml ;
5707 sub read_yaml {
5708     my($self) = @_;
5709     return $self->{yaml_content} if exists $self->{yaml_content};
5710     my $build_dir = $self->{build_dir};
5711     my $yaml = File::Spec->catfile($build_dir,"META.yml");
5712     $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
5713     return unless -f $yaml;
5714     if ($CPAN::META->has_inst("YAML")) {
5715         eval { $self->{yaml_content} = YAML::LoadFile($yaml); };
5716         if ($@) {
5717             $CPAN::Frontend->mywarn("Error while parsing META.yml: $@");
5718             return;
5719         }
5720         if (not exists $self->{yaml_content}{dynamic_config}
5721             or $self->{yaml_content}{dynamic_config}
5722            ) {
5723             $self->{yaml_content} = undef;
5724         }
5725     }
5726     $self->debug(sprintf "yaml_content[%s]", $self->{yaml_content} || "UNDEF")
5727         if $CPAN::DEBUG;
5728     return $self->{yaml_content};
5729 }
5730
5731 #-> sub CPAN::Distribution::prereq_pm ;
5732 sub prereq_pm {
5733     my($self) = @_;
5734     return $self->{prereq_pm} if
5735         exists $self->{prereq_pm_detected} && $self->{prereq_pm_detected};
5736     return unless $self->{writemakefile}  # no need to have succeeded
5737                                           # but we must have run it
5738         || $self->{modulebuild};
5739     my($req,$breq);
5740     if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
5741         $req =  $yaml->{requires} || {};
5742         $breq =  $yaml->{build_requires} || {};
5743         undef $req unless ref $req eq "HASH" && %$req;
5744         if ($req) {
5745             if ($yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
5746                 my $eummv = do { local $^W = 0; $1+0; };
5747                 if ($eummv < 6.2501) {
5748                     # thanks to Slaven for digging that out: MM before
5749                     # that could be wrong because it could reflect a
5750                     # previous release
5751                     undef $req;
5752                 }
5753             }
5754             my $areq;
5755             my $do_replace;
5756             while (my($k,$v) = each %{$req||{}}) {
5757                 if ($v =~ /\d/) {
5758                     $areq->{$k} = $v;
5759                 } elsif ($k =~ /[A-Za-z]/ &&
5760                          $v =~ /[A-Za-z]/ &&
5761                          $CPAN::META->exists("Module",$v)
5762                         ) {
5763                     $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
5764                                             "requires hash: $k => $v; I'll take both ".
5765                                             "key and value as a module name\n");
5766                     $CPAN::Frontend->mysleep(1);
5767                     $areq->{$k} = 0;
5768                     $areq->{$v} = 0;
5769                     $do_replace++;
5770                 }
5771             }
5772             $req = $areq if $do_replace;
5773         }
5774         if ($req) {
5775             # XXX maybe needs to be reconsidered: what do we if perl
5776             # is too old? I think, we will set $self->{make} to
5777             # Distrostatus NO and wind up the stack.
5778             delete $req->{perl};
5779         }
5780     }
5781     unless ($req || $breq) {
5782         my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
5783         my $makefile = File::Spec->catfile($build_dir,"Makefile");
5784         my $fh;
5785         if (-f $makefile
5786             and
5787             $fh = FileHandle->new("<$makefile\0")) {
5788             local($/) = "\n";
5789             while (<$fh>) {
5790                 last if /MakeMaker post_initialize section/;
5791                 my($p) = m{^[\#]
5792                            \s+PREREQ_PM\s+=>\s+(.+)
5793                        }x;
5794                 next unless $p;
5795                 # warn "Found prereq expr[$p]";
5796
5797                 #  Regexp modified by A.Speer to remember actual version of file
5798                 #  PREREQ_PM hash key wants, then add to
5799                 while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
5800                     # In case a prereq is mentioned twice, complain.
5801                     if ( defined $req->{$1} ) {
5802                         warn "Warning: PREREQ_PM mentions $1 more than once, ".
5803                             "last mention wins";
5804                     }
5805                     $req->{$1} = $2;
5806                 }
5807                 last;
5808             }
5809         } elsif (-f "Build") {
5810             if ($CPAN::META->has_inst("Module::Build")) {
5811                 $req  = Module::Build->current->requires();
5812                 $breq = Module::Build->current->build_requires();
5813             }
5814         }
5815     }
5816     if (-f "Build.PL" && ! -f "Makefile.PL" && ! exists $req->{"Module::Build"}) {
5817         $CPAN::Frontend->mywarn("  Warning: CPAN.pm discovered Module::Build as ".
5818                                 "undeclared prerequisite.\n".
5819                                 "  Adding it now as such.\n"
5820                                );
5821         $CPAN::Frontend->mysleep(5);
5822         $req->{"Module::Build"} = 0;
5823         delete $self->{writemakefile};
5824     }
5825     $self->{prereq_pm_detected}++;
5826     return $self->{prereq_pm} = { requires => $req, build_requires => $breq };
5827 }
5828
5829 #-> sub CPAN::Distribution::test ;
5830 sub test {
5831     my($self) = @_;
5832     $self->make;
5833     if ($CPAN::Signal){
5834       delete $self->{force_update};
5835       return;
5836     }
5837     # warn "XDEBUG: checking for notest: $self->{notest} $self";
5838     if ($self->{notest}) {
5839         $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
5840         return 1;
5841     }
5842
5843     my $make = $self->{modulebuild} ? "Build" : "make";
5844     $CPAN::Frontend->myprint("Running $make test\n");
5845     if (my @prereq = $self->unsat_prereq){
5846       return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
5847     }
5848   EXCUSE: {
5849         my @e;
5850         unless (exists $self->{make} or exists $self->{later}) {
5851             push @e,
5852                 "Make had some problems, won't test";
5853         }
5854
5855         exists $self->{make} and
5856             (
5857              $self->{make}->can("failed") ?
5858              $self->{make}->failed :
5859              $self->{make} =~ /^NO/
5860             ) and push @e, "Can't test without successful make";
5861
5862         exists $self->{build_dir} or push @e, "Has no own directory";
5863         $self->{badtestcnt} ||= 0;
5864         $self->{badtestcnt} > 0 and
5865             push @e, "Won't repeat unsuccessful test during this command";
5866
5867         exists $self->{later} and length($self->{later}) and
5868             push @e, $self->{later};
5869
5870         if ($self->{modulebuild}) {
5871             my $v = CPAN::Shell->expand("Module","Test::Harness")->inst_version;
5872             if (CPAN::Version->vlt($v,2.62)) {
5873                 push @e, qq{The version of your Test::Harness is only
5874   '$v', you need at least '2.62'. Please upgrade your Test::Harness.};
5875             }
5876         }
5877
5878         if ($CPAN::META->{is_tested}{$self->{build_dir}}
5879             &&
5880             exists $self->{make_test}
5881             &&
5882             !(
5883               $self->{make_test}->can("failed") ?
5884               $self->{make_test}->failed :
5885               $self->{make_test} =~ /^NO/
5886              )
5887            ) {
5888             push @e, "Already tested successfully";
5889         }
5890
5891         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
5892     }
5893     chdir $self->{'build_dir'} or
5894         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
5895     $self->debug("Changed directory to $self->{'build_dir'}")
5896         if $CPAN::DEBUG;
5897
5898     if ($^O eq 'MacOS') {
5899         Mac::BuildTools::make_test($self);
5900         return;
5901     }
5902
5903     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
5904                            ? $ENV{PERL5LIB}
5905                            : ($ENV{PERLLIB} || "");
5906
5907     $CPAN::META->set_perl5lib;
5908     local $ENV{MAKEFLAGS}; # protect us from outer make calls
5909
5910     my $system;
5911     if ($self->{modulebuild}) {
5912         $system = sprintf "%s test", $self->_build_command();
5913     } else {
5914         $system = join " ", $self->_make_command(), "test";
5915     }
5916     my $tests_ok;
5917     if ( $CPAN::Config->{test_report} &&
5918          $CPAN::META->has_inst("CPAN::Reporter") ) {
5919             $tests_ok = CPAN::Reporter::test($self, $system);
5920     } else {
5921             $tests_ok = system($system) == 0;
5922     }
5923     if ( $tests_ok ) {
5924          $CPAN::Frontend->myprint("  $system -- OK\n");
5925          $CPAN::META->is_tested($self->{'build_dir'});
5926          $self->{make_test} = CPAN::Distrostatus->new("YES");
5927     } else {
5928          $self->{make_test} = CPAN::Distrostatus->new("NO");
5929          $self->{badtestcnt}++;
5930          $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
5931     }
5932 }
5933
5934 #-> sub CPAN::Distribution::clean ;
5935 sub clean {
5936     my($self) = @_;
5937     my $make = $self->{modulebuild} ? "Build" : "make";
5938     $CPAN::Frontend->myprint("Running $make clean\n");
5939     unless (exists $self->{archived}) {
5940         $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped".
5941                                 "/untarred, nothing done\n");
5942         return 1;
5943     }
5944     unless (exists $self->{build_dir}) {
5945         $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
5946         return 1;
5947     }
5948   EXCUSE: {
5949         my @e;
5950         exists $self->{make_clean} and $self->{make_clean} eq "YES" and
5951             push @e, "make clean already called once";
5952         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
5953     }
5954     chdir $self->{'build_dir'} or
5955         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
5956     $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
5957
5958     if ($^O eq 'MacOS') {
5959         Mac::BuildTools::make_clean($self);
5960         return;
5961     }
5962
5963     my $system;
5964     if ($self->{modulebuild}) {
5965         unless (-f "Build") {
5966             my $cwd = Cwd::cwd;
5967             $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
5968                                     " in cwd[$cwd]. Danger, Will Robinson!");
5969             $CPAN::Frontend->mysleep(5);
5970         }
5971         $system = sprintf "%s clean", $self->_build_command();
5972     } else {
5973         $system  = join " ", $self->_make_command(), "clean";
5974     }
5975     if (system($system) == 0) {
5976       $CPAN::Frontend->myprint("  $system -- OK\n");
5977
5978       # $self->force;
5979
5980       # Jost Krieger pointed out that this "force" was wrong because
5981       # it has the effect that the next "install" on this distribution
5982       # will untar everything again. Instead we should bring the
5983       # object's state back to where it is after untarring.
5984
5985       for my $k (qw(
5986                     force_update
5987                     install
5988                     writemakefile
5989                     make
5990                     make_test
5991                    )) {
5992           delete $self->{$k};
5993       }
5994       $self->{make_clean} = CPAN::Distrostatus->new("YES");
5995
5996     } else {
5997       # Hmmm, what to do if make clean failed?
5998
5999       $self->{make_clean} = CPAN::Distrostatus->new("NO");
6000       $CPAN::Frontend->mywarn(qq{  $system -- NOT OK\n});
6001
6002       # 2006-02-27: seems silly to me to force a make now
6003       # $self->force("make"); # so that this directory won't be used again
6004
6005     }
6006 }
6007
6008 #-> sub CPAN::Distribution::install ;
6009 sub install {
6010     my($self) = @_;
6011     $self->test;
6012     if ($CPAN::Signal){
6013       delete $self->{force_update};
6014       return;
6015     }
6016     my $make = $self->{modulebuild} ? "Build" : "make";
6017     $CPAN::Frontend->myprint("Running $make install\n");
6018   EXCUSE: {
6019         my @e;
6020         exists $self->{build_dir} or push @e, "Has no own directory";
6021
6022         unless (exists $self->{make} or exists $self->{later}) {
6023             push @e,
6024                 "Make had some problems, won't install";
6025         }
6026
6027         exists $self->{make} and
6028             (
6029              $self->{make}->can("failed") ?
6030              $self->{make}->failed :
6031              $self->{make} =~ /^NO/
6032             ) and
6033                 push @e, "make had returned bad status, install seems impossible";
6034
6035         if (exists $self->{make_test} and
6036             (
6037              $self->{make_test}->can("failed") ?
6038              $self->{make_test}->failed :
6039              $self->{make_test} =~ /^NO/
6040             )){
6041             if ($self->{force_update}) {
6042                 $self->{make_test}->text("FAILED but failure ignored because ".
6043                                          "'force' in effect");
6044             } else {
6045                 push @e, "make test had returned bad status, ".
6046                     "won't install without force"
6047             }
6048         }
6049         if (exists $self->{'install'}) {
6050             if ($self->{'install'}->can("text") ?
6051                 $self->{'install'}->text eq "YES" :
6052                 $self->{'install'} =~ /^YES/
6053                ) {
6054                 push @e, "Already done";
6055             } else {
6056                 # comment in Todo on 2006-02-11; maybe retry?
6057                 push @e, "Already tried without success";
6058             }
6059         }
6060
6061         exists $self->{later} and length($self->{later}) and
6062             push @e, $self->{later};
6063
6064         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
6065     }
6066     chdir $self->{'build_dir'} or
6067         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
6068     $self->debug("Changed directory to $self->{'build_dir'}")
6069         if $CPAN::DEBUG;
6070
6071     if ($^O eq 'MacOS') {
6072         Mac::BuildTools::make_install($self);
6073         return;
6074     }
6075
6076     my $system;
6077     if ($self->{modulebuild}) {
6078         my($mbuild_install_build_command) =
6079             exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
6080                 $CPAN::Config->{mbuild_install_build_command} ?
6081                     $CPAN::Config->{mbuild_install_build_command} :
6082                         $self->_build_command();
6083         $system = sprintf("%s install %s",
6084                           $mbuild_install_build_command,
6085                           $CPAN::Config->{mbuild_install_arg},
6086                          );
6087     } else {
6088         my($make_install_make_command) = $CPAN::Config->{make_install_make_command} ||
6089             $self->_make_command();
6090         $system = sprintf("%s install %s",
6091                           $make_install_make_command,
6092                           $CPAN::Config->{make_install_arg},
6093                          );
6094     }
6095
6096     my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 ";
6097     $CPAN::Config->{build_requires_install_policy}||="ask/yes";
6098     my $id = $self->id;
6099     my $reqtype = $self->{reqtype};
6100     unless ($reqtype) {
6101         $CPAN::Frontend->mywarn("Unknown require type for '$id', setting to 'r'. ".
6102                                 "This should not happen and is construed a bug.\n");
6103         $reqtype = "r";
6104     }
6105     my $want_install = "yes";
6106     if ($reqtype eq "b") {
6107         if ($CPAN::Config->{build_requires_install_policy} eq "no") {
6108             $want_install = "no";
6109         } elsif ($CPAN::Config->{build_requires_install_policy} =~ m|^ask/(.+)|) {
6110             my $default = $1;
6111             $default = "yes" unless $default =~ /^(y|n)/i;
6112             $want_install =
6113                 CPAN::Shell::colorable_makemaker_prompt
6114                       ("$id is just needed temporarily during building or testing. ".
6115                        "Do you want to install it permanently? (Y/n)",
6116                        $default);
6117         }
6118     }
6119     unless ($want_install =~ /^y/i) {
6120         my $is_only = "is only 'build_requires'";
6121         $CPAN::Frontend->mywarn("Not installing because $is_only\n");
6122         $self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
6123         delete $self->{force_update};
6124         return;
6125     }
6126     my($pipe) = FileHandle->new("$system $stderr |");
6127     my($makeout) = "";
6128     while (<$pipe>){
6129         print $_; # intentionally NOT use Frontend->myprint because it
6130                   # looks irritating when we markup in color what we
6131                   # just pass through from an external program
6132         $makeout .= $_;
6133     }
6134     $pipe->close;
6135     if ($?==0) {
6136         $CPAN::Frontend->myprint("  $system -- OK\n");
6137         $CPAN::META->is_installed($self->{build_dir});
6138         return $self->{install} = CPAN::Distrostatus->new("YES");
6139     } else {
6140         $self->{install} = CPAN::Distrostatus->new("NO");
6141         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
6142         if (
6143             $makeout =~ /permission/s
6144             && $> > 0
6145             && (
6146                 ! $CPAN::Config->{make_install_make_command}
6147                 || $CPAN::Config->{make_install_make_command} eq $CPAN::Config->{make}
6148                )
6149            ) {
6150             $CPAN::Frontend->myprint(
6151                                      qq{----\n}.
6152                                      qq{  You may have to su }.
6153                                      qq{to root to install the package\n}.
6154                                      qq{  (Or you may want to run something like\n}.
6155                                      qq{    o conf make_install_make_command 'sudo make'\n}.
6156                                      qq{  to raise your permissions.}
6157                                     );
6158         }
6159     }
6160     delete $self->{force_update};
6161 }
6162
6163 #-> sub CPAN::Distribution::dir ;
6164 sub dir {
6165     shift->{'build_dir'};
6166 }
6167
6168 #-> sub CPAN::Distribution::perldoc ;
6169 sub perldoc {
6170     my($self) = @_;
6171
6172     my($dist) = $self->id;
6173     my $package = $self->called_for;
6174
6175     $self->_display_url( $CPAN::Defaultdocs . $package );
6176 }
6177
6178 #-> sub CPAN::Distribution::_check_binary ;
6179 sub _check_binary {
6180     my ($dist,$shell,$binary) = @_;
6181     my ($pid,$out);
6182
6183     $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
6184       if $CPAN::DEBUG;
6185
6186     local *README;
6187     $pid = open README, "which $binary|"
6188       or $CPAN::Frontend->mydie(qq{Could not fork 'which $binary': $!});
6189     while (<README>) {
6190         $out .= $_;
6191     }
6192     close README or die "Could not run 'which $binary': $!";
6193
6194     $CPAN::Frontend->myprint(qq{   + $out \n})
6195       if $CPAN::DEBUG && $out;
6196
6197     return $out;
6198 }
6199
6200 #-> sub CPAN::Distribution::_display_url ;
6201 sub _display_url {
6202     my($self,$url) = @_;
6203     my($res,$saved_file,$pid,$out);
6204
6205     $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
6206       if $CPAN::DEBUG;
6207
6208     # should we define it in the config instead?
6209     my $html_converter = "html2text";
6210
6211     my $web_browser = $CPAN::Config->{'lynx'} || undef;
6212     my $web_browser_out = $web_browser
6213       ? CPAN::Distribution->_check_binary($self,$web_browser)
6214         : undef;
6215
6216     if ($web_browser_out) {
6217         # web browser found, run the action
6218         my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
6219         $CPAN::Frontend->myprint(qq{system[$browser $url]})
6220           if $CPAN::DEBUG;
6221         $CPAN::Frontend->myprint(qq{
6222 Displaying URL
6223   $url
6224 with browser $browser
6225 });
6226         $CPAN::Frontend->mysleep(1);
6227         system("$browser $url");
6228         if ($saved_file) { 1 while unlink($saved_file) }
6229     } else {
6230         # web browser not found, let's try text only
6231         my $html_converter_out =
6232           CPAN::Distribution->_check_binary($self,$html_converter);
6233         $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out);
6234
6235         if ($html_converter_out ) {
6236             # html2text found, run it
6237             $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
6238             $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n})
6239                 unless defined($saved_file);
6240
6241             local *README;
6242             $pid = open README, "$html_converter $saved_file |"
6243               or $CPAN::Frontend->mydie(qq{
6244 Could not fork '$html_converter $saved_file': $!});
6245             my($fh,$filename);
6246             if ($CPAN::META->has_inst("File::Temp")) {
6247                 $fh = File::Temp->new(
6248                                       template => 'cpan_htmlconvert_XXXX',
6249                                       suffix => '.txt',
6250                                       unlink => 0,
6251                                      );
6252                 $filename = $fh->filename;
6253             } else {
6254                 $filename = "cpan_htmlconvert_$$.txt";
6255                 $fh = FileHandle->new();
6256                 open $fh, ">$filename" or die;
6257             }
6258             while (<README>) {
6259                 $fh->print($_);
6260             }
6261             close README or
6262                 $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
6263             my $tmpin = $fh->filename;
6264             $CPAN::Frontend->myprint(sprintf(qq{
6265 Run '%s %s' and
6266 saved output to %s\n},
6267                                              $html_converter,
6268                                              $saved_file,
6269                                              $tmpin,
6270                                             )) if $CPAN::DEBUG;
6271             close $fh;
6272             local *FH;
6273             open FH, $tmpin
6274                 or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
6275             my $fh_pager = FileHandle->new;
6276             local($SIG{PIPE}) = "IGNORE";
6277             my $pager = $CPAN::Config->{'pager'} || "cat";
6278             $fh_pager->open("|$pager")
6279                 or $CPAN::Frontend->mydie(qq{
6280 Could not open pager '$pager': $!});
6281             $CPAN::Frontend->myprint(qq{
6282 Displaying URL
6283   $url
6284 with pager "$pager"
6285 });
6286             $CPAN::Frontend->mysleep(1);
6287             $fh_pager->print(<FH>);
6288             $fh_pager->close;
6289         } else {
6290             # coldn't find the web browser or html converter
6291             $CPAN::Frontend->myprint(qq{
6292 You need to install lynx or $html_converter to use this feature.});
6293         }
6294     }
6295 }
6296
6297 #-> sub CPAN::Distribution::_getsave_url ;
6298 sub _getsave_url {
6299     my($dist, $shell, $url) = @_;
6300
6301     $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
6302       if $CPAN::DEBUG;
6303
6304     my($fh,$filename);
6305     if ($CPAN::META->has_inst("File::Temp")) {
6306         $fh = File::Temp->new(
6307                               template => "cpan_getsave_url_XXXX",
6308                               suffix => ".html",
6309                               unlink => 0,
6310                              );
6311         $filename = $fh->filename;
6312     } else {
6313         $fh = FileHandle->new;
6314         $filename = "cpan_getsave_url_$$.html";
6315     }
6316     my $tmpin = $filename;
6317     if ($CPAN::META->has_usable('LWP')) {
6318         $CPAN::Frontend->myprint("Fetching with LWP:
6319   $url
6320 ");
6321         my $Ua;
6322         CPAN::LWP::UserAgent->config;
6323         eval { $Ua = CPAN::LWP::UserAgent->new; };
6324         if ($@) {
6325             $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
6326             return;
6327         } else {
6328             my($var);
6329             $Ua->proxy('http', $var)
6330                 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
6331             $Ua->no_proxy($var)
6332                 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
6333         }
6334
6335         my $req = HTTP::Request->new(GET => $url);
6336         $req->header('Accept' => 'text/html');
6337         my $res = $Ua->request($req);
6338         if ($res->is_success) {
6339             $CPAN::Frontend->myprint(" + request successful.\n")
6340                 if $CPAN::DEBUG;
6341             print $fh $res->content;
6342             close $fh;
6343             $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
6344                 if $CPAN::DEBUG;
6345             return $tmpin;
6346         } else {
6347             $CPAN::Frontend->myprint(sprintf(
6348                                              "LWP failed with code[%s], message[%s]\n",
6349                                              $res->code,
6350                                              $res->message,
6351                                             ));
6352             return;
6353         }
6354     } else {
6355         $CPAN::Frontend->mywarn("  LWP not available\n");
6356         return;
6357     }
6358 }
6359
6360 # sub CPAN::Distribution::_build_command
6361 sub _build_command {
6362     my($self) = @_;
6363     if ($^O eq "MSWin32") { # special code needed at least up to
6364                             # Module::Build 0.2611 and 0.2706; a fix
6365                             # in M:B has been promised 2006-01-30
6366         my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
6367         return "$perl ./Build";
6368     }
6369     return "./Build";
6370 }
6371
6372 package CPAN::Bundle;
6373 use strict;
6374
6375 sub look {
6376     my $self = shift;
6377     $CPAN::Frontend->myprint($self->as_string);
6378 }
6379
6380 sub undelay {
6381     my $self = shift;
6382     delete $self->{later};
6383     for my $c ( $self->contains ) {
6384         my $obj = CPAN::Shell->expandany($c) or next;
6385         $obj->undelay;
6386     }
6387 }
6388
6389 # mark as dirty/clean
6390 #-> sub CPAN::Bundle::color_cmd_tmps ;
6391 sub color_cmd_tmps {
6392     my($self) = shift;
6393     my($depth) = shift || 0;
6394     my($color) = shift || 0;
6395     my($ancestors) = shift || [];
6396     # a module needs to recurse to its cpan_file, a distribution needs
6397     # to recurse into its prereq_pms, a bundle needs to recurse into its modules
6398
6399     return if exists $self->{incommandcolor}
6400         && $self->{incommandcolor}==$color;
6401     if ($depth>=100){
6402         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
6403     }
6404     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
6405
6406     for my $c ( $self->contains ) {
6407         my $obj = CPAN::Shell->expandany($c) or next;
6408         CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
6409         $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
6410     }
6411     if ($color==0) {
6412         delete $self->{badtestcnt};
6413     }
6414     $self->{incommandcolor} = $color;
6415 }
6416
6417 #-> sub CPAN::Bundle::as_string ;
6418 sub as_string {
6419     my($self) = @_;
6420     $self->contains;
6421     # following line must be "=", not "||=" because we have a moving target
6422     $self->{INST_VERSION} = $self->inst_version;
6423     return $self->SUPER::as_string;
6424 }
6425
6426 #-> sub CPAN::Bundle::contains ;
6427 sub contains {
6428     my($self) = @_;
6429     my($inst_file) = $self->inst_file || "";
6430     my($id) = $self->id;
6431     $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
6432     if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) {
6433         undef $inst_file;
6434     }
6435     unless ($inst_file) {
6436         # Try to get at it in the cpan directory
6437         $self->debug("no inst_file") if $CPAN::DEBUG;
6438         my $cpan_file;
6439         $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
6440               $cpan_file = $self->cpan_file;
6441         if ($cpan_file eq "N/A") {
6442             $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
6443   Maybe stale symlink? Maybe removed during session? Giving up.\n");
6444         }
6445         my $dist = $CPAN::META->instance('CPAN::Distribution',
6446                                          $self->cpan_file);
6447         $dist->get;
6448         $self->debug("id[$dist->{ID}]") if $CPAN::DEBUG;
6449         my($todir) = $CPAN::Config->{'cpan_home'};
6450         my(@me,$from,$to,$me);
6451         @me = split /::/, $self->id;
6452         $me[-1] .= ".pm";
6453         $me = File::Spec->catfile(@me);
6454         $from = $self->find_bundle_file($dist->{'build_dir'},join('/',@me));
6455         $to = File::Spec->catfile($todir,$me);
6456         File::Path::mkpath(File::Basename::dirname($to));
6457         File::Copy::copy($from, $to)
6458               or Carp::confess("Couldn't copy $from to $to: $!");
6459         $inst_file = $to;
6460     }
6461     my @result;
6462     my $fh = FileHandle->new;
6463     local $/ = "\n";
6464     open($fh,$inst_file) or die "Could not open '$inst_file': $!";
6465     my $in_cont = 0;
6466     $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
6467     while (<$fh>) {
6468         $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
6469             m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
6470         next unless $in_cont;
6471         next if /^=/;
6472         s/\#.*//;
6473         next if /^\s+$/;
6474         chomp;
6475         push @result, (split " ", $_, 2)[0];
6476     }
6477     close $fh;
6478     delete $self->{STATUS};
6479     $self->{CONTAINS} = \@result;
6480     $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
6481     unless (@result) {
6482         $CPAN::Frontend->mywarn(qq{
6483 The bundle file "$inst_file" may be a broken
6484 bundlefile. It seems not to contain any bundle definition.
6485 Please check the file and if it is bogus, please delete it.
6486 Sorry for the inconvenience.
6487 });
6488     }
6489     @result;
6490 }
6491
6492 #-> sub CPAN::Bundle::find_bundle_file
6493 # $where is in local format, $what is in unix format
6494 sub find_bundle_file {
6495     my($self,$where,$what) = @_;
6496     $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
6497 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
6498 ###    my $bu = File::Spec->catfile($where,$what);
6499 ###    return $bu if -f $bu;
6500     my $manifest = File::Spec->catfile($where,"MANIFEST");
6501     unless (-f $manifest) {
6502         require ExtUtils::Manifest;
6503         my $cwd = CPAN::anycwd();
6504         $self->safe_chdir($where);
6505         ExtUtils::Manifest::mkmanifest();
6506         $self->safe_chdir($cwd);
6507     }
6508     my $fh = FileHandle->new($manifest)
6509         or Carp::croak("Couldn't open $manifest: $!");
6510     local($/) = "\n";
6511     my $bundle_filename = $what;
6512     $bundle_filename =~ s|Bundle.*/||;
6513     my $bundle_unixpath;
6514     while (<$fh>) {
6515         next if /^\s*\#/;
6516         my($file) = /(\S+)/;
6517         if ($file =~ m|\Q$what\E$|) {
6518             $bundle_unixpath = $file;
6519             # return File::Spec->catfile($where,$bundle_unixpath); # bad
6520             last;
6521         }
6522         # retry if she managed to have no Bundle directory
6523         $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
6524     }
6525     return File::Spec->catfile($where, split /\//, $bundle_unixpath)
6526         if $bundle_unixpath;
6527     Carp::croak("Couldn't find a Bundle file in $where");
6528 }
6529
6530 # needs to work quite differently from Module::inst_file because of
6531 # cpan_home/Bundle/ directory and the possibility that we have
6532 # shadowing effect. As it makes no sense to take the first in @INC for
6533 # Bundles, we parse them all for $VERSION and take the newest.
6534
6535 #-> sub CPAN::Bundle::inst_file ;
6536 sub inst_file {
6537     my($self) = @_;
6538     my($inst_file);
6539     my(@me);
6540     @me = split /::/, $self->id;
6541     $me[-1] .= ".pm";
6542     my($incdir,$bestv);
6543     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
6544         my $bfile = File::Spec->catfile($incdir, @me);
6545         CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
6546         next unless -f $bfile;
6547         my $foundv = MM->parse_version($bfile);
6548         if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
6549             $self->{INST_FILE} = $bfile;
6550             $self->{INST_VERSION} = $bestv = $foundv;
6551         }
6552     }
6553     $self->{INST_FILE};
6554 }
6555
6556 #-> sub CPAN::Bundle::inst_version ;
6557 sub inst_version {
6558     my($self) = @_;
6559     $self->inst_file; # finds INST_VERSION as side effect
6560     $self->{INST_VERSION};
6561 }
6562
6563 #-> sub CPAN::Bundle::rematein ;
6564 sub rematein {
6565     my($self,$meth) = @_;
6566     $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
6567     my($id) = $self->id;
6568     Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
6569         unless $self->inst_file || $self->cpan_file;
6570     my($s,%fail);
6571     for $s ($self->contains) {
6572         my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
6573             $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
6574         if ($type eq 'CPAN::Distribution') {
6575             $CPAN::Frontend->mywarn(qq{
6576 The Bundle }.$self->id.qq{ contains
6577 explicitly a file $s.
6578 });
6579             $CPAN::Frontend->mysleep(3);
6580         }
6581         # possibly noisy action:
6582         $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
6583         my $obj = $CPAN::META->instance($type,$s);
6584         $obj->{reqtype} = $self->{reqtype};
6585         $obj->$meth();
6586         if ($obj->isa('CPAN::Bundle')
6587             &&
6588             exists $obj->{install_failed}
6589             &&
6590             ref($obj->{install_failed}) eq "HASH"
6591            ) {
6592           for (keys %{$obj->{install_failed}}) {
6593             $self->{install_failed}{$_} = undef; # propagate faiure up
6594                                                  # to me in a
6595                                                  # recursive call
6596             $fail{$s} = 1; # the bundle itself may have succeeded but
6597                            # not all children
6598           }
6599         } else {
6600           my $success;
6601           $success = $obj->can("uptodate") ? $obj->uptodate : 0;
6602           $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
6603           if ($success) {
6604             delete $self->{install_failed}{$s};
6605           } else {
6606             $fail{$s} = 1;
6607           }
6608         }
6609     }
6610
6611     # recap with less noise
6612     if ( $meth eq "install" ) {
6613         if (%fail) {
6614             require Text::Wrap;
6615             my $raw = sprintf(qq{Bundle summary:
6616 The following items in bundle %s had installation problems:},
6617                               $self->id
6618                              );
6619             $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
6620             $CPAN::Frontend->myprint("\n");
6621             my $paragraph = "";
6622             my %reported;
6623             for $s ($self->contains) {
6624               if ($fail{$s}){
6625                 $paragraph .= "$s ";
6626                 $self->{install_failed}{$s} = undef;
6627                 $reported{$s} = undef;
6628               }
6629             }
6630             my $report_propagated;
6631             for $s (sort keys %{$self->{install_failed}}) {
6632               next if exists $reported{$s};
6633               $paragraph .= "and the following items had problems
6634 during recursive bundle calls: " unless $report_propagated++;
6635               $paragraph .= "$s ";
6636             }
6637             $CPAN::Frontend->myprint(Text::Wrap::fill("  ","  ",$paragraph));
6638             $CPAN::Frontend->myprint("\n");
6639         } else {
6640             $self->{'install'} = 'YES';
6641         }
6642     }
6643 }
6644
6645 # If a bundle contains another that contains an xs_file we have here,
6646 # we just don't bother I suppose
6647 #-> sub CPAN::Bundle::xs_file
6648 sub xs_file {
6649     return 0;
6650 }
6651
6652 #-> sub CPAN::Bundle::force ;
6653 sub force   { shift->rematein('force',@_); }
6654 #-> sub CPAN::Bundle::notest ;
6655 sub notest  { shift->rematein('notest',@_); }
6656 #-> sub CPAN::Bundle::get ;
6657 sub get     { shift->rematein('get',@_); }
6658 #-> sub CPAN::Bundle::make ;
6659 sub make    { shift->rematein('make',@_); }
6660 #-> sub CPAN::Bundle::test ;
6661 sub test    {
6662     my $self = shift;
6663     $self->{badtestcnt} ||= 0;
6664     $self->rematein('test',@_);
6665 }
6666 #-> sub CPAN::Bundle::install ;
6667 sub install {
6668   my $self = shift;
6669   $self->rematein('install',@_);
6670 }
6671 #-> sub CPAN::Bundle::clean ;
6672 sub clean   { shift->rematein('clean',@_); }
6673
6674 #-> sub CPAN::Bundle::uptodate ;
6675 sub uptodate {
6676     my($self) = @_;
6677     return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
6678     my $c;
6679     foreach $c ($self->contains) {
6680         my $obj = CPAN::Shell->expandany($c);
6681         return 0 unless $obj->uptodate;
6682     }
6683     return 1;
6684 }
6685
6686 #-> sub CPAN::Bundle::readme ;
6687 sub readme  {
6688     my($self) = @_;
6689     my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
6690 No File found for bundle } . $self->id . qq{\n}), return;
6691     $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
6692     $CPAN::META->instance('CPAN::Distribution',$file)->readme;
6693 }
6694
6695 package CPAN::Module;
6696 use strict;
6697
6698 # Accessors
6699 # sub CPAN::Module::userid
6700 sub userid {
6701     my $self = shift;
6702     my $ro = $self->ro;
6703     return unless $ro;
6704     return $ro->{userid} || $ro->{CPAN_USERID};
6705 }
6706 # sub CPAN::Module::description
6707 sub description {
6708     my $self = shift;
6709     my $ro = $self->ro or return "";
6710     $ro->{description}
6711 }
6712
6713 sub distribution {
6714     my($self) = @_;
6715     CPAN::Shell->expand("Distribution",$self->cpan_file);
6716 }
6717
6718 # sub CPAN::Module::undelay
6719 sub undelay {
6720     my $self = shift;
6721     delete $self->{later};
6722     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
6723         $dist->undelay;
6724     }
6725 }
6726
6727 # mark as dirty/clean
6728 #-> sub CPAN::Module::color_cmd_tmps ;
6729 sub color_cmd_tmps {
6730     my($self) = shift;
6731     my($depth) = shift || 0;
6732     my($color) = shift || 0;
6733     my($ancestors) = shift || [];
6734     # a module needs to recurse to its cpan_file
6735
6736     return if exists $self->{incommandcolor}
6737         && $self->{incommandcolor}==$color;
6738     return if $depth>=1 && $self->uptodate;
6739     if ($depth>=100){
6740         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
6741     }
6742     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
6743
6744     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
6745         $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
6746     }
6747     if ($color==0) {
6748         delete $self->{badtestcnt};
6749     }
6750     $self->{incommandcolor} = $color;
6751 }
6752
6753 #-> sub CPAN::Module::as_glimpse ;
6754 sub as_glimpse {
6755     my($self) = @_;
6756     my(@m);
6757     my $class = ref($self);
6758     $class =~ s/^CPAN:://;
6759     my $color_on = "";
6760     my $color_off = "";
6761     if (
6762         $CPAN::Shell::COLOR_REGISTERED
6763         &&
6764         $CPAN::META->has_inst("Term::ANSIColor")
6765         &&
6766         $self->description
6767        ) {
6768         $color_on = Term::ANSIColor::color("green");
6769         $color_off = Term::ANSIColor::color("reset");
6770     }
6771     my $uptodateness = " ";
6772     if ($class eq "Bundle") {
6773     } elsif ($self->uptodate) {
6774         $uptodateness = "=";
6775     } elsif ($self->inst_version) {
6776         $uptodateness = "<";
6777     }
6778     push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n",
6779                      $class,
6780                      $uptodateness,
6781                      $color_on,
6782                      $self->id,
6783                      $color_off,
6784                      ($self->distribution ?
6785                       $self->distribution->pretty_id :
6786                       $self->cpan_userid
6787                      ),
6788                     );
6789     join "", @m;
6790 }
6791
6792 #-> sub CPAN::Module::dslip_status
6793 sub dslip_status {
6794     my($self) = @_;
6795     my($stat);
6796     @{$stat->{D}}{qw,i c a b R M S,}     = qw,idea
6797                                               pre-alpha alpha beta released
6798                                               mature standard,;
6799     @{$stat->{S}}{qw,m d u n a,}         = qw,mailing-list
6800                                               developer comp.lang.perl.*
6801                                               none abandoned,;
6802     @{$stat->{L}}{qw,p c + o h,}         = qw,perl C C++ other hybrid,;
6803     @{$stat->{I}}{qw,f r O p h n,}       = qw,functions
6804                                               references+ties
6805                                               object-oriented pragma
6806                                               hybrid none,;
6807     @{$stat->{P}}{qw,p g l b a o d r n,} = qw,Standard-Perl
6808                                               GPL LGPL
6809                                               BSD Artistic
6810                                               open-source
6811                                               distribution_allowed
6812                                               restricted_distribution
6813                                               no_licence,;
6814     for my $x (qw(d s l i p)) {
6815         $stat->{$x}{' '} = 'unknown';
6816         $stat->{$x}{'?'} = 'unknown';
6817     }
6818     my $ro = $self->ro;
6819     return +{} unless $ro && $ro->{statd};
6820     return {
6821             D  => $ro->{statd},
6822             S  => $ro->{stats},
6823             L  => $ro->{statl},
6824             I  => $ro->{stati},
6825             P  => $ro->{statp},
6826             DV => $stat->{D}{$ro->{statd}},
6827             SV => $stat->{S}{$ro->{stats}},
6828             LV => $stat->{L}{$ro->{statl}},
6829             IV => $stat->{I}{$ro->{stati}},
6830             PV => $stat->{P}{$ro->{statp}},
6831            };
6832 }
6833
6834 #-> sub CPAN::Module::as_string ;
6835 sub as_string {
6836     my($self) = @_;
6837     my(@m);
6838     CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
6839     my $class = ref($self);
6840     $class =~ s/^CPAN:://;
6841     local($^W) = 0;
6842     push @m, $class, " id = $self->{ID}\n";
6843     my $sprintf = "    %-12s %s\n";
6844     push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
6845         if $self->description;
6846     my $sprintf2 = "    %-12s %s (%s)\n";
6847     my($userid);
6848     $userid = $self->userid;
6849     if ( $userid ){
6850         my $author;
6851         if ($author = CPAN::Shell->expand('Author',$userid)) {
6852           my $email = "";
6853           my $m; # old perls
6854           if ($m = $author->email) {
6855             $email = " <$m>";
6856           }
6857           push @m, sprintf(
6858                            $sprintf2,
6859                            'CPAN_USERID',
6860                            $userid,
6861                            $author->fullname . $email
6862                           );
6863         }
6864     }
6865     push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
6866         if $self->cpan_version;
6867     if (my $cpan_file = $self->cpan_file){
6868         push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
6869         if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
6870             my $upload_date = $dist->upload_date;
6871             if ($upload_date) {
6872                 push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
6873             }
6874         }
6875     }
6876     my $sprintf3 = "    %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n";
6877     my $dslip = $self->dslip_status;
6878     push @m, sprintf(
6879                      $sprintf3,
6880                      'DSLIP_STATUS',
6881                      @{$dslip}{qw(D S L I P DV SV LV IV PV)},
6882                     ) if $dslip->{D};
6883     my $local_file = $self->inst_file;
6884     unless ($self->{MANPAGE}) {
6885         my $manpage;
6886         if ($local_file) {
6887             $manpage = $self->manpage_headline($local_file);
6888         } else {
6889             # If we have already untarred it, we should look there
6890             my $dist = $CPAN::META->instance('CPAN::Distribution',
6891                                              $self->cpan_file);
6892             # warn "dist[$dist]";
6893             # mff=manifest file; mfh=manifest handle
6894             my($mff,$mfh);
6895             if (
6896                 $dist->{build_dir}
6897                 and
6898                 (-f  ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
6899                 and
6900                 $mfh = FileHandle->new($mff)
6901                ) {
6902                 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
6903                 my $lfre = $self->id; # local file RE
6904                 $lfre =~ s/::/./g;
6905                 $lfre .= "\\.pm\$";
6906                 my($lfl); # local file file
6907                 local $/ = "\n";
6908                 my(@mflines) = <$mfh>;
6909                 for (@mflines) {
6910                     s/^\s+//;
6911                     s/\s.*//s;
6912                 }
6913                 while (length($lfre)>5 and !$lfl) {
6914                     ($lfl) = grep /$lfre/, @mflines;
6915                     CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
6916                     $lfre =~ s/.+?\.//;
6917                 }
6918                 $lfl =~ s/\s.*//; # remove comments
6919                 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
6920                 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
6921                 # warn "lfl_abs[$lfl_abs]";
6922                 if (-f $lfl_abs) {
6923                     $manpage = $self->manpage_headline($lfl_abs);
6924                 }
6925             }
6926         }
6927         $self->{MANPAGE} = $manpage if $manpage;
6928     }
6929     my($item);
6930     for $item (qw/MANPAGE/) {
6931         push @m, sprintf($sprintf, $item, $self->{$item})
6932             if exists $self->{$item};
6933     }
6934     for $item (qw/CONTAINS/) {
6935         push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
6936             if exists $self->{$item} && @{$self->{$item}};
6937     }
6938     push @m, sprintf($sprintf, 'INST_FILE',
6939                      $local_file || "(not installed)");
6940     push @m, sprintf($sprintf, 'INST_VERSION',
6941                      $self->inst_version) if $local_file;
6942     join "", @m, "\n";
6943 }
6944
6945 sub manpage_headline {
6946   my($self,$local_file) = @_;
6947   my(@local_file) = $local_file;
6948   $local_file =~ s/\.pm(?!\n)\Z/.pod/;
6949   push @local_file, $local_file;
6950   my(@result,$locf);
6951   for $locf (@local_file) {
6952     next unless -f $locf;
6953     my $fh = FileHandle->new($locf)
6954         or $Carp::Frontend->mydie("Couldn't open $locf: $!");
6955     my $inpod = 0;
6956     local $/ = "\n";
6957     while (<$fh>) {
6958       $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
6959           m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
6960       next unless $inpod;
6961       next if /^=/;
6962       next if /^\s+$/;
6963       chomp;
6964       push @result, $_;
6965     }
6966     close $fh;
6967     last if @result;
6968   }
6969   for (@result) {
6970       s/^\s+//;
6971       s/\s+$//;
6972   }
6973   join " ", @result;
6974 }
6975
6976 #-> sub CPAN::Module::cpan_file ;
6977 # Note: also inherited by CPAN::Bundle
6978 sub cpan_file {
6979     my $self = shift;
6980     CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
6981     unless ($self->ro) {
6982         CPAN::Index->reload;
6983     }
6984     my $ro = $self->ro;
6985     if ($ro && defined $ro->{CPAN_FILE}){
6986         return $ro->{CPAN_FILE};
6987     } else {
6988         my $userid = $self->userid;
6989         if ( $userid ) {
6990             if ($CPAN::META->exists("CPAN::Author",$userid)) {
6991                 my $author = $CPAN::META->instance("CPAN::Author",
6992                                                    $userid);
6993                 my $fullname = $author->fullname;
6994                 my $email = $author->email;
6995                 unless (defined $fullname && defined $email) {
6996                     return sprintf("Contact Author %s",
6997                                    $userid,
6998                                   );
6999                 }
7000                 return "Contact Author $fullname <$email>";
7001             } else {
7002                 return "Contact Author $userid (Email address not available)";
7003             }
7004         } else {
7005             return "N/A";
7006         }
7007     }
7008 }
7009
7010 #-> sub CPAN::Module::cpan_version ;
7011 sub cpan_version {
7012     my $self = shift;
7013
7014     my $ro = $self->ro;
7015     unless ($ro) {
7016         # Can happen with modules that are not on CPAN
7017         $ro = {};
7018     }
7019     $ro->{CPAN_VERSION} = 'undef'
7020         unless defined $ro->{CPAN_VERSION};
7021     $ro->{CPAN_VERSION};
7022 }
7023
7024 #-> sub CPAN::Module::force ;
7025 sub force {
7026     my($self) = @_;
7027     $self->{'force_update'}++;
7028 }
7029
7030 sub notest {
7031     my($self) = @_;
7032     # warn "XDEBUG: set notest for Module";
7033     $self->{'notest'}++;
7034 }
7035
7036 #-> sub CPAN::Module::rematein ;
7037 sub rematein {
7038     my($self,$meth) = @_;
7039     $CPAN::Frontend->myprint(sprintf("Running %s for module %s\n",
7040                                      $meth,
7041                                      $self->id));
7042     my $cpan_file = $self->cpan_file;
7043     if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
7044       $CPAN::Frontend->mywarn(sprintf qq{
7045   The module %s isn\'t available on CPAN.
7046
7047   Either the module has not yet been uploaded to CPAN, or it is
7048   temporary unavailable. Please contact the author to find out
7049   more about the status. Try 'i %s'.
7050 },
7051                               $self->id,
7052                               $self->id,
7053                              );
7054       return;
7055     }
7056     my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
7057     $pack->called_for($self->id);
7058     $pack->force($meth) if exists $self->{'force_update'};
7059     $pack->notest($meth) if exists $self->{'notest'};
7060
7061     $pack->{reqtype} ||= "";
7062     CPAN->debug("dist-reqtype[$pack->{reqtype}]".
7063                 "self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG;
7064         if ($pack->{reqtype}) {
7065             if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) {
7066                 $pack->{reqtype} = $self->{reqtype};
7067                 if (
7068                     exists $pack->{install}
7069                     &&
7070                     (
7071                      $pack->{install}->can("failed") ?
7072                      $pack->{install}->failed :
7073                      $pack->{install} =~ /^NO/
7074                     )
7075                    ) {
7076                     delete $pack->{install};
7077                     $CPAN::Frontend->mywarn
7078                         ("Promoting $pack->{ID} from 'build_requires' to 'requires'");
7079                 }
7080             }
7081         } else {
7082             $pack->{reqtype} = $self->{reqtype};
7083         }
7084
7085     eval {
7086         $pack->$meth();
7087     };
7088     my $err = $@;
7089     $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
7090     $pack->unnotest if $pack->can("unnotest") && exists $self->{'notest'};
7091     delete $self->{'force_update'};
7092     delete $self->{'notest'};
7093     if ($err) {
7094         die $err;
7095     }
7096 }
7097
7098 #-> sub CPAN::Module::perldoc ;
7099 sub perldoc { shift->rematein('perldoc') }
7100 #-> sub CPAN::Module::readme ;
7101 sub readme  { shift->rematein('readme') }
7102 #-> sub CPAN::Module::look ;
7103 sub look    { shift->rematein('look') }
7104 #-> sub CPAN::Module::cvs_import ;
7105 sub cvs_import { shift->rematein('cvs_import') }
7106 #-> sub CPAN::Module::get ;
7107 sub get     { shift->rematein('get',@_) }
7108 #-> sub CPAN::Module::make ;
7109 sub make    { shift->rematein('make') }
7110 #-> sub CPAN::Module::test ;
7111 sub test   {
7112     my $self = shift;
7113     $self->{badtestcnt} ||= 0;
7114     $self->rematein('test',@_);
7115 }
7116 #-> sub CPAN::Module::uptodate ;
7117 sub uptodate {
7118     my($self) = @_;
7119     local($_); # protect against a bug in MakeMaker 6.17
7120     my($latest) = $self->cpan_version;
7121     $latest ||= 0;
7122     my($inst_file) = $self->inst_file;
7123     my($have) = 0;
7124     if (defined $inst_file) {
7125         $have = $self->inst_version;
7126     }
7127     local($^W)=0;
7128     if ($inst_file
7129         &&
7130         ! CPAN::Version->vgt($latest, $have)
7131        ) {
7132         CPAN->debug("returning uptodate. inst_file[$inst_file] ".
7133                     "latest[$latest] have[$have]") if $CPAN::DEBUG;
7134         return 1;
7135     }
7136     return;
7137 }
7138 #-> sub CPAN::Module::install ;
7139 sub install {
7140     my($self) = @_;
7141     my($doit) = 0;
7142     if ($self->uptodate
7143         &&
7144         not exists $self->{'force_update'}
7145        ) {
7146         $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
7147                                          $self->id,
7148                                          $self->inst_version,
7149                                         ));
7150     } else {
7151         $doit = 1;
7152     }
7153     my $ro = $self->ro;
7154     if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
7155         $CPAN::Frontend->mywarn(qq{
7156 \n\n\n     ***WARNING***
7157      The module $self->{ID} has no active maintainer.\n\n\n
7158 });
7159         $CPAN::Frontend->mysleep(5);
7160     }
7161     $self->rematein('install') if $doit;
7162 }
7163 #-> sub CPAN::Module::clean ;
7164 sub clean  { shift->rematein('clean') }
7165
7166 #-> sub CPAN::Module::inst_file ;
7167 sub inst_file {
7168     my($self) = @_;
7169     my($dir,@packpath);
7170     @packpath = split /::/, $self->{ID};
7171     $packpath[-1] .= ".pm";
7172     if (@packpath == 1 && $packpath[0] eq "readline.pm") {
7173         unshift @packpath, "Term", "ReadLine"; # historical reasons
7174     }
7175     foreach $dir (@INC) {
7176         my $pmfile = File::Spec->catfile($dir,@packpath);
7177         if (-f $pmfile){
7178             return $pmfile;
7179         }
7180     }
7181     return;
7182 }
7183
7184 #-> sub CPAN::Module::xs_file ;
7185 sub xs_file {
7186     my($self) = @_;
7187     my($dir,@packpath);
7188     @packpath = split /::/, $self->{ID};
7189     push @packpath, $packpath[-1];
7190     $packpath[-1] .= "." . $Config::Config{'dlext'};
7191     foreach $dir (@INC) {
7192         my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
7193         if (-f $xsfile){
7194             return $xsfile;
7195         }
7196     }
7197     return;
7198 }
7199
7200 #-> sub CPAN::Module::inst_version ;
7201 sub inst_version {
7202     my($self) = @_;
7203     my $parsefile = $self->inst_file or return;
7204     local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
7205     my $have;
7206
7207     $have = MM->parse_version($parsefile) || "undef";
7208     $have =~ s/^ //; # since the %vd hack these two lines here are needed
7209     $have =~ s/ $//; # trailing whitespace happens all the time
7210
7211     # My thoughts about why %vd processing should happen here
7212
7213     # Alt1 maintain it as string with leading v:
7214     # read index files     do nothing
7215     # compare it           use utility for compare
7216     # print it             do nothing
7217
7218     # Alt2 maintain it as what it is
7219     # read index files     convert
7220     # compare it           use utility because there's still a ">" vs "gt" issue
7221     # print it             use CPAN::Version for print
7222
7223     # Seems cleaner to hold it in memory as a string starting with a "v"
7224
7225     # If the author of this module made a mistake and wrote a quoted
7226     # "v1.13" instead of v1.13, we simply leave it at that with the
7227     # effect that *we* will treat it like a v-tring while the rest of
7228     # perl won't. Seems sensible when we consider that any action we
7229     # could take now would just add complexity.
7230
7231     $have = CPAN::Version->readable($have);
7232
7233     $have =~ s/\s*//g; # stringify to float around floating point issues
7234     $have; # no stringify needed, \s* above matches always
7235 }
7236
7237 package CPAN;
7238 use strict;
7239
7240 1;
7241
7242
7243 __END__
7244
7245 =head1 NAME
7246
7247 CPAN - query, download and build perl modules from CPAN sites
7248
7249 =head1 SYNOPSIS
7250
7251 Interactive mode:
7252
7253   perl -MCPAN -e shell;
7254
7255 Batch mode:
7256
7257   use CPAN;
7258
7259   # modules:
7260
7261   $mod = "Acme::Meta";
7262   install $mod;
7263   CPAN::Shell->install($mod);                    # same thing
7264   CPAN::Shell->expandany($mod)->install;         # same thing
7265   CPAN::Shell->expand("Module",$mod)->install;   # same thing
7266   CPAN::Shell->expand("Module",$mod)
7267     ->distribution->install;                     # same thing
7268
7269   # distributions:
7270
7271   $distro = "NWCLARK/Acme-Meta-0.01.tar.gz";
7272   install $distro;                                # same thing
7273   CPAN::Shell->install($distro);                  # same thing
7274   CPAN::Shell->expandany($distro)->install;       # same thing
7275   CPAN::Shell->expand("Distribution",$distro)->install; # same thing
7276
7277 =head1 STATUS
7278
7279 This module and its competitor, the CPANPLUS module, are both much
7280 cooler than the other.
7281
7282 =head1 COMPATIBILITY
7283
7284 CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted
7285 newer versions. It is getting more and more difficult to get the
7286 minimal prerequisites working on older perls. It is close to
7287 impossible to get the whole Bundle::CPAN working there. If you're in
7288 the position to have only these old versions, be advised that CPAN is
7289 designed to work fine without the Bundle::CPAN installed.
7290
7291 To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is
7292 compatible with ancient perls and that File::Temp is listed as a
7293 prerequisite but CPAN has reasonable workarounds if it is missing.
7294
7295 =head1 DESCRIPTION
7296
7297 The CPAN module is designed to automate the make and install of perl
7298 modules and extensions. It includes some primitive searching
7299 capabilities and knows how to use Net::FTP or LWP (or some external
7300 download clients) to fetch the raw data from the net.
7301
7302 Modules are fetched from one or more of the mirrored CPAN
7303 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
7304 directory.
7305
7306 The CPAN module also supports the concept of named and versioned
7307 I<bundles> of modules. Bundles simplify the handling of sets of
7308 related modules. See Bundles below.
7309
7310 The package contains a session manager and a cache manager. There is
7311 no status retained between sessions. The session manager keeps track
7312 of what has been fetched, built and installed in the current
7313 session. The cache manager keeps track of the disk space occupied by
7314 the make processes and deletes excess space according to a simple FIFO
7315 mechanism.
7316
7317 All methods provided are accessible in a programmer style and in an
7318 interactive shell style.
7319
7320 =head2 CPAN::shell([$prompt, $command]) Starting Interactive Mode
7321
7322 The interactive mode is entered by running
7323
7324     perl -MCPAN -e shell
7325
7326 which puts you into a readline interface. You will have the most fun if
7327 you install Term::ReadKey and Term::ReadLine to enjoy both history and
7328 command completion.
7329
7330 Once you are on the command line, type 'h' and the rest should be
7331 self-explanatory.
7332
7333 The function call C<shell> takes two optional arguments, one is the
7334 prompt, the second is the default initial command line (the latter
7335 only works if a real ReadLine interface module is installed).
7336
7337 The most common uses of the interactive modes are
7338
7339 =over 2
7340
7341 =item Searching for authors, bundles, distribution files and modules
7342
7343 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
7344 for each of the four categories and another, C<i> for any of the
7345 mentioned four. Each of the four entities is implemented as a class
7346 with slightly differing methods for displaying an object.
7347
7348 Arguments you pass to these commands are either strings exactly matching
7349 the identification string of an object or regular expressions that are
7350 then matched case-insensitively against various attributes of the
7351 objects. The parser recognizes a regular expression only if you
7352 enclose it between two slashes.
7353
7354 The principle is that the number of found objects influences how an
7355 item is displayed. If the search finds one item, the result is
7356 displayed with the rather verbose method C<as_string>, but if we find
7357 more than one, we display each object with the terse method
7358 C<as_glimpse>.
7359
7360 =item make, test, install, clean  modules or distributions
7361
7362 These commands take any number of arguments and investigate what is
7363 necessary to perform the action. If the argument is a distribution
7364 file name (recognized by embedded slashes), it is processed. If it is
7365 a module, CPAN determines the distribution file in which this module
7366 is included and processes that, following any dependencies named in
7367 the module's META.yml or Makefile.PL (this behavior is controlled by
7368 the configuration parameter C<prerequisites_policy>.)
7369
7370 Any C<make> or C<test> are run unconditionally. An
7371
7372   install <distribution_file>
7373
7374 also is run unconditionally. But for
7375
7376   install <module>
7377
7378 CPAN checks if an install is actually needed for it and prints
7379 I<module up to date> in the case that the distribution file containing
7380 the module doesn't need to be updated.
7381
7382 CPAN also keeps track of what it has done within the current session
7383 and doesn't try to build a package a second time regardless if it
7384 succeeded or not. The C<force> pragma may precede another command
7385 (currently: C<make>, C<test>, or C<install>) and executes the
7386 command from scratch and tries to continue in case of some errors.
7387
7388 Example:
7389
7390     cpan> install OpenGL
7391     OpenGL is up to date.
7392     cpan> force install OpenGL
7393     Running make
7394     OpenGL-0.4/
7395     OpenGL-0.4/COPYRIGHT
7396     [...]
7397
7398 The C<notest> pragma may be set to skip the test part in the build
7399 process.
7400
7401 Example:
7402
7403     cpan> notest install Tk
7404
7405 A C<clean> command results in a
7406
7407   make clean
7408
7409 being executed within the distribution file's working directory.
7410
7411 =item get, readme, perldoc, look module or distribution
7412
7413 C<get> downloads a distribution file without further action. C<readme>
7414 displays the README file of the associated distribution. C<Look> gets
7415 and untars (if not yet done) the distribution file, changes to the
7416 appropriate directory and opens a subshell process in that directory.
7417 C<perldoc> displays the pod documentation of the module in html or
7418 plain text format.
7419
7420 =item ls author
7421
7422 =item ls globbing_expression
7423
7424 The first form lists all distribution files in and below an author's
7425 CPAN directory as they are stored in the CHECKUMS files distributed on
7426 CPAN. The listing goes recursive into all subdirectories.
7427
7428 The second form allows to limit or expand the output with shell
7429 globbing as in the following examples:
7430
7431           ls JV/make*
7432           ls GSAR/*make*
7433           ls */*make*
7434
7435 The last example is very slow and outputs extra progress indicators
7436 that break the alignment of the result.
7437
7438 Note that globbing only lists directories explicitly asked for, for
7439 example FOO/* will not list FOO/bar/Acme-Sthg-n.nn.tar.gz. This may be
7440 regarded as a bug and may be changed in future versions.
7441
7442 =item failed
7443
7444 The C<failed> command reports all distributions that failed on one of
7445 C<make>, C<test> or C<install> for some reason in the currently
7446 running shell session.
7447
7448 =item Lockfile
7449
7450 Interactive sessions maintain a lockfile, per default C<~/.cpan/.lock>
7451 (but the directory can be configured via the C<cpan_home> config
7452 variable). The shell is a bit picky if you try to start another CPAN
7453 session. It dies immediately if there is a lockfile and the lock seems
7454 to belong to a running process. In case you want to run a second shell
7455 session, it is probably safest to maintain another directory, say
7456 C<~/.cpan-for-X/> and a C<~/.cpan-for-X/CPAN/MyConfig.pm> that
7457 contains the configuration options. Then you can start the second
7458 shell with
7459
7460   perl -I ~/.cpan-for-X -MCPAN::MyConfig -MCPAN -e shell
7461
7462 =item Signals
7463
7464 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
7465 in the cpan-shell it is intended that you can press C<^C> anytime and
7466 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
7467 to clean up and leave the shell loop. You can emulate the effect of a
7468 SIGTERM by sending two consecutive SIGINTs, which usually means by
7469 pressing C<^C> twice.
7470
7471 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
7472 SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl
7473 Build.PL> subprocess.
7474
7475 =back
7476
7477 =head2 CPAN::Shell
7478
7479 The commands that are available in the shell interface are methods in
7480 the package CPAN::Shell. If you enter the shell command, all your
7481 input is split by the Text::ParseWords::shellwords() routine which
7482 acts like most shells do. The first word is being interpreted as the
7483 method to be called and the rest of the words are treated as arguments
7484 to this method. Continuation lines are supported if a line ends with a
7485 literal backslash.
7486
7487 =head2 autobundle
7488
7489 C<autobundle> writes a bundle file into the
7490 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
7491 a list of all modules that are both available from CPAN and currently
7492 installed within @INC. The name of the bundle file is based on the
7493 current date and a counter.
7494
7495 =head2 recompile
7496
7497 recompile() is a very special command in that it takes no argument and
7498 runs the make/test/install cycle with brute force over all installed
7499 dynamically loadable extensions (aka XS modules) with 'force' in
7500 effect. The primary purpose of this command is to finish a network
7501 installation. Imagine, you have a common source tree for two different
7502 architectures. You decide to do a completely independent fresh
7503 installation. You start on one architecture with the help of a Bundle
7504 file produced earlier. CPAN installs the whole Bundle for you, but
7505 when you try to repeat the job on the second architecture, CPAN
7506 responds with a C<"Foo up to date"> message for all modules. So you
7507 invoke CPAN's recompile on the second architecture and you're done.
7508
7509 Another popular use for C<recompile> is to act as a rescue in case your
7510 perl breaks binary compatibility. If one of the modules that CPAN uses
7511 is in turn depending on binary compatibility (so you cannot run CPAN
7512 commands), then you should try the CPAN::Nox module for recovery.
7513
7514 =head2 upgrade [Module|/Regex/]...
7515
7516 The C<upgrade> command first runs an C<r> command with the given
7517 arguments and then installs the newest versions of all modules that
7518 were listed by that.
7519
7520 =head2 mkmyconfig
7521
7522 mkmyconfig() writes your own CPAN::MyConfig file into your ~/.cpan/
7523 directory so that you can save your own preferences instead of the
7524 system wide ones.
7525
7526 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
7527
7528 Although it may be considered internal, the class hierarchy does matter
7529 for both users and programmer. CPAN.pm deals with above mentioned four
7530 classes, and all those classes share a set of methods. A classical
7531 single polymorphism is in effect. A metaclass object registers all
7532 objects of all kinds and indexes them with a string. The strings
7533 referencing objects have a separated namespace (well, not completely
7534 separated):
7535
7536          Namespace                         Class
7537
7538    words containing a "/" (slash)      Distribution
7539     words starting with Bundle::          Bundle
7540           everything else            Module or Author
7541
7542 Modules know their associated Distribution objects. They always refer
7543 to the most recent official release. Developers may mark their releases
7544 as unstable development versions (by inserting an underbar into the
7545 module version number which will also be reflected in the distribution
7546 name when you run 'make dist'), so the really hottest and newest
7547 distribution is not always the default.  If a module Foo circulates
7548 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
7549 way to install version 1.23 by saying
7550
7551     install Foo
7552
7553 This would install the complete distribution file (say
7554 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
7555 like to install version 1.23_90, you need to know where the
7556 distribution file resides on CPAN relative to the authors/id/
7557 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
7558 so you would have to say
7559
7560     install BAR/Foo-1.23_90.tar.gz
7561
7562 The first example will be driven by an object of the class
7563 CPAN::Module, the second by an object of class CPAN::Distribution.
7564
7565 =head1 PROGRAMMER'S INTERFACE
7566
7567 If you do not enter the shell, the available shell commands are both
7568 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
7569 functions in the calling package (C<install(...)>).
7570
7571 There's currently only one class that has a stable interface -
7572 CPAN::Shell. All commands that are available in the CPAN shell are
7573 methods of the class CPAN::Shell. Each of the commands that produce
7574 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
7575 the IDs of all modules within the list.
7576
7577 =over 2
7578
7579 =item expand($type,@things)
7580
7581 The IDs of all objects available within a program are strings that can
7582 be expanded to the corresponding real objects with the
7583 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
7584 list of CPAN::Module objects according to the C<@things> arguments
7585 given. In scalar context it only returns the first element of the
7586 list.
7587
7588 =item expandany(@things)
7589
7590 Like expand, but returns objects of the appropriate type, i.e.
7591 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
7592 CPAN::Distribution objects for distributions. Note: it does not expand
7593 to CPAN::Author objects.
7594
7595 =item Programming Examples
7596
7597 This enables the programmer to do operations that combine
7598 functionalities that are available in the shell.
7599
7600     # install everything that is outdated on my disk:
7601     perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
7602
7603     # install my favorite programs if necessary:
7604     for $mod (qw(Net::FTP Digest::SHA Data::Dumper)){
7605         my $obj = CPAN::Shell->expand('Module',$mod);
7606         $obj->install;
7607     }
7608
7609     # list all modules on my disk that have no VERSION number
7610     for $mod (CPAN::Shell->expand("Module","/./")){
7611         next unless $mod->inst_file;
7612         # MakeMaker convention for undefined $VERSION:
7613         next unless $mod->inst_version eq "undef";
7614         print "No VERSION in ", $mod->id, "\n";
7615     }
7616
7617     # find out which distribution on CPAN contains a module:
7618     print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
7619
7620 Or if you want to write a cronjob to watch The CPAN, you could list
7621 all modules that need updating. First a quick and dirty way:
7622
7623     perl -e 'use CPAN; CPAN::Shell->r;'
7624
7625 If you don't want to get any output in the case that all modules are
7626 up to date, you can parse the output of above command for the regular
7627 expression //modules are up to date// and decide to mail the output
7628 only if it doesn't match. Ick?
7629
7630 If you prefer to do it more in a programmer style in one single
7631 process, maybe something like this suits you better:
7632
7633   # list all modules on my disk that have newer versions on CPAN
7634   for $mod (CPAN::Shell->expand("Module","/./")){
7635     next unless $mod->inst_file;
7636     next if $mod->uptodate;
7637     printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
7638         $mod->id, $mod->inst_version, $mod->cpan_version;
7639   }
7640
7641 If that gives you too much output every day, you maybe only want to
7642 watch for three modules. You can write
7643
7644   for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
7645
7646 as the first line instead. Or you can combine some of the above
7647 tricks:
7648
7649   # watch only for a new mod_perl module
7650   $mod = CPAN::Shell->expand("Module","mod_perl");
7651   exit if $mod->uptodate;
7652   # new mod_perl arrived, let me know all update recommendations
7653   CPAN::Shell->r;
7654
7655 =back
7656
7657 =head2 Methods in the other Classes
7658
7659 The programming interface for the classes CPAN::Module,
7660 CPAN::Distribution, CPAN::Bundle, and CPAN::Author is still considered
7661 beta and partially even alpha. In the following paragraphs only those
7662 methods are documented that have proven useful over a longer time and
7663 thus are unlikely to change.
7664
7665 =over 4
7666
7667 =item CPAN::Author::as_glimpse()
7668
7669 Returns a one-line description of the author
7670
7671 =item CPAN::Author::as_string()
7672
7673 Returns a multi-line description of the author
7674
7675 =item CPAN::Author::email()
7676
7677 Returns the author's email address
7678
7679 =item CPAN::Author::fullname()
7680
7681 Returns the author's name
7682
7683 =item CPAN::Author::name()
7684
7685 An alias for fullname
7686
7687 =item CPAN::Bundle::as_glimpse()
7688
7689 Returns a one-line description of the bundle
7690
7691 =item CPAN::Bundle::as_string()
7692
7693 Returns a multi-line description of the bundle
7694
7695 =item CPAN::Bundle::clean()
7696
7697 Recursively runs the C<clean> method on all items contained in the bundle.
7698
7699 =item CPAN::Bundle::contains()
7700
7701 Returns a list of objects' IDs contained in a bundle. The associated
7702 objects may be bundles, modules or distributions.
7703
7704 =item CPAN::Bundle::force($method,@args)
7705
7706 Forces CPAN to perform a task that normally would have failed. Force
7707 takes as arguments a method name to be called and any number of
7708 additional arguments that should be passed to the called method. The
7709 internals of the object get the needed changes so that CPAN.pm does
7710 not refuse to take the action. The C<force> is passed recursively to
7711 all contained objects.
7712
7713 =item CPAN::Bundle::get()
7714
7715 Recursively runs the C<get> method on all items contained in the bundle
7716
7717 =item CPAN::Bundle::inst_file()
7718
7719 Returns the highest installed version of the bundle in either @INC or
7720 C<$CPAN::Config->{cpan_home}>. Note that this is different from
7721 CPAN::Module::inst_file.
7722
7723 =item CPAN::Bundle::inst_version()
7724
7725 Like CPAN::Bundle::inst_file, but returns the $VERSION
7726
7727 =item CPAN::Bundle::uptodate()
7728
7729 Returns 1 if the bundle itself and all its members are uptodate.
7730
7731 =item CPAN::Bundle::install()
7732
7733 Recursively runs the C<install> method on all items contained in the bundle
7734
7735 =item CPAN::Bundle::make()
7736
7737 Recursively runs the C<make> method on all items contained in the bundle
7738
7739 =item CPAN::Bundle::readme()
7740
7741 Recursively runs the C<readme> method on all items contained in the bundle
7742
7743 =item CPAN::Bundle::test()
7744
7745 Recursively runs the C<test> method on all items contained in the bundle
7746
7747 =item CPAN::Distribution::as_glimpse()
7748
7749 Returns a one-line description of the distribution
7750
7751 =item CPAN::Distribution::as_string()
7752
7753 Returns a multi-line description of the distribution
7754
7755 =item CPAN::Distribution::author
7756
7757 Returns the CPAN::Author object of the maintainer who uploaded this
7758 distribution
7759
7760 =item CPAN::Distribution::clean()
7761
7762 Changes to the directory where the distribution has been unpacked and
7763 runs C<make clean> there.
7764
7765 =item CPAN::Distribution::containsmods()
7766
7767 Returns a list of IDs of modules contained in a distribution file.
7768 Only works for distributions listed in the 02packages.details.txt.gz
7769 file. This typically means that only the most recent version of a
7770 distribution is covered.
7771
7772 =item CPAN::Distribution::cvs_import()
7773
7774 Changes to the directory where the distribution has been unpacked and
7775 runs something like
7776
7777     cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
7778
7779 there.
7780
7781 =item CPAN::Distribution::dir()
7782
7783 Returns the directory into which this distribution has been unpacked.
7784
7785 =item CPAN::Distribution::force($method,@args)
7786
7787 Forces CPAN to perform a task that normally would have failed. Force
7788 takes as arguments a method name to be called and any number of
7789 additional arguments that should be passed to the called method. The
7790 internals of the object get the needed changes so that CPAN.pm does
7791 not refuse to take the action.
7792
7793 =item CPAN::Distribution::get()
7794
7795 Downloads the distribution from CPAN and unpacks it. Does nothing if
7796 the distribution has already been downloaded and unpacked within the
7797 current session.
7798
7799 =item CPAN::Distribution::install()
7800
7801 Changes to the directory where the distribution has been unpacked and
7802 runs the external command C<make install> there. If C<make> has not
7803 yet been run, it will be run first. A C<make test> will be issued in
7804 any case and if this fails, the install will be canceled. The
7805 cancellation can be avoided by letting C<force> run the C<install> for
7806 you.
7807
7808 Note that install() gives no meaningful return value. See uptodate().
7809
7810 =item CPAN::Distribution::isa_perl()
7811
7812 Returns 1 if this distribution file seems to be a perl distribution.
7813 Normally this is derived from the file name only, but the index from
7814 CPAN can contain a hint to achieve a return value of true for other
7815 filenames too.
7816
7817 =item CPAN::Distribution::look()
7818
7819 Changes to the directory where the distribution has been unpacked and
7820 opens a subshell there. Exiting the subshell returns.
7821
7822 =item CPAN::Distribution::make()
7823
7824 First runs the C<get> method to make sure the distribution is
7825 downloaded and unpacked. Changes to the directory where the
7826 distribution has been unpacked and runs the external commands C<perl
7827 Makefile.PL> or C<perl Build.PL> and C<make> there.
7828
7829 =item CPAN::Distribution::perldoc()
7830
7831 Downloads the pod documentation of the file associated with a
7832 distribution (in html format) and runs it through the external
7833 command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
7834 isn't available, it converts it to plain text with external
7835 command html2text and runs it through the pager specified
7836 in C<$CPAN::Config->{pager}>
7837
7838 =item CPAN::Distribution::prereq_pm()
7839
7840 Returns the hash reference that has been announced by a distribution
7841 as the merge of the C<requires> element and the C<build_requires>
7842 element of the META.yml or the C<PREREQ_PM> hash in the
7843 C<Makefile.PL>. Note: works only after an attempt has been made to
7844 C<make> the distribution. Returns undef otherwise.
7845
7846 =item CPAN::Distribution::readme()
7847
7848 Downloads the README file associated with a distribution and runs it
7849 through the pager specified in C<$CPAN::Config->{pager}>.
7850
7851 =item CPAN::Distribution::read_yaml()
7852
7853 Returns the content of the META.yml of this distro as a hashref. Note:
7854 works only after an attempt has been made to C<make> the distribution.
7855 Returns undef otherwise.
7856
7857 =item CPAN::Distribution::test()
7858
7859 Changes to the directory where the distribution has been unpacked and
7860 runs C<make test> there.
7861
7862 =item CPAN::Distribution::uptodate()
7863
7864 Returns 1 if all the modules contained in the distribution are
7865 uptodate. Relies on containsmods.
7866
7867 =item CPAN::Index::force_reload()
7868
7869 Forces a reload of all indices.
7870
7871 =item CPAN::Index::reload()
7872
7873 Reloads all indices if they have not been read for more than
7874 C<$CPAN::Config->{index_expire}> days.
7875
7876 =item CPAN::InfoObj::dump()
7877
7878 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
7879 inherit this method. It prints the data structure associated with an
7880 object. Useful for debugging. Note: the data structure is considered
7881 internal and thus subject to change without notice.
7882
7883 =item CPAN::Module::as_glimpse()
7884
7885 Returns a one-line description of the module in four columns: The
7886 first column contains the word C<Module>, the second column consists
7887 of one character: an equals sign if this module is already installed
7888 and uptodate, a less-than sign if this module is installed but can be
7889 upgraded, and a space if the module is not installed. The third column
7890 is the name of the module and the fourth column gives maintainer or
7891 distribution information.
7892
7893 =item CPAN::Module::as_string()
7894
7895 Returns a multi-line description of the module
7896
7897 =item CPAN::Module::clean()
7898
7899 Runs a clean on the distribution associated with this module.
7900
7901 =item CPAN::Module::cpan_file()
7902
7903 Returns the filename on CPAN that is associated with the module.
7904
7905 =item CPAN::Module::cpan_version()
7906
7907 Returns the latest version of this module available on CPAN.
7908
7909 =item CPAN::Module::cvs_import()
7910
7911 Runs a cvs_import on the distribution associated with this module.
7912
7913 =item CPAN::Module::description()
7914
7915 Returns a 44 character description of this module. Only available for
7916 modules listed in The Module List (CPAN/modules/00modlist.long.html
7917 or 00modlist.long.txt.gz)
7918
7919 =item CPAN::Module::distribution()
7920
7921 Returns the CPAN::Distribution object that contains the current
7922 version of this module.
7923
7924 =item CPAN::Module::dslip_status()
7925
7926 Returns a hash reference. The keys of the hash are the letters C<D>,
7927 C<S>, C<L>, C<I>, and <P>, for development status, support level,
7928 language, interface and public licence respectively. The data for the
7929 DSLIP status are collected by pause.perl.org when authors register
7930 their namespaces. The values of the 5 hash elements are one-character
7931 words whose meaning is described in the table below. There are also 5
7932 hash elements C<DV>, C<SV>, C<LV>, C<IV>, and <PV> that carry a more
7933 verbose value of the 5 status variables.
7934
7935 Where the 'DSLIP' characters have the following meanings:
7936
7937   D - Development Stage  (Note: *NO IMPLIED TIMESCALES*):
7938     i   - Idea, listed to gain consensus or as a placeholder
7939     c   - under construction but pre-alpha (not yet released)
7940     a/b - Alpha/Beta testing
7941     R   - Released
7942     M   - Mature (no rigorous definition)
7943     S   - Standard, supplied with Perl 5
7944
7945   S - Support Level:
7946     m   - Mailing-list
7947     d   - Developer
7948     u   - Usenet newsgroup comp.lang.perl.modules
7949     n   - None known, try comp.lang.perl.modules
7950     a   - abandoned; volunteers welcome to take over maintainance
7951
7952   L - Language Used:
7953     p   - Perl-only, no compiler needed, should be platform independent
7954     c   - C and perl, a C compiler will be needed
7955     h   - Hybrid, written in perl with optional C code, no compiler needed
7956     +   - C++ and perl, a C++ compiler will be needed
7957     o   - perl and another language other than C or C++
7958
7959   I - Interface Style
7960     f   - plain Functions, no references used
7961     h   - hybrid, object and function interfaces available
7962     n   - no interface at all (huh?)
7963     r   - some use of unblessed References or ties
7964     O   - Object oriented using blessed references and/or inheritance
7965
7966   P - Public License
7967     p   - Standard-Perl: user may choose between GPL and Artistic
7968     g   - GPL: GNU General Public License
7969     l   - LGPL: "GNU Lesser General Public License" (previously known as
7970           "GNU Library General Public License")
7971     b   - BSD: The BSD License
7972     a   - Artistic license alone
7973     o   - open source: appoved by www.opensource.org
7974     d   - allows distribution without restrictions
7975     r   - restricted distribtion
7976     n   - no license at all
7977
7978 =item CPAN::Module::force($method,@args)
7979
7980 Forces CPAN to perform a task that normally would have failed. Force
7981 takes as arguments a method name to be called and any number of
7982 additional arguments that should be passed to the called method. The
7983 internals of the object get the needed changes so that CPAN.pm does
7984 not refuse to take the action.
7985
7986 =item CPAN::Module::get()
7987
7988 Runs a get on the distribution associated with this module.
7989
7990 =item CPAN::Module::inst_file()
7991
7992 Returns the filename of the module found in @INC. The first file found
7993 is reported just like perl itself stops searching @INC when it finds a
7994 module.
7995
7996 =item CPAN::Module::inst_version()
7997
7998 Returns the version number of the module in readable format.
7999
8000 =item CPAN::Module::install()
8001
8002 Runs an C<install> on the distribution associated with this module.
8003
8004 =item CPAN::Module::look()
8005
8006 Changes to the directory where the distribution associated with this
8007 module has been unpacked and opens a subshell there. Exiting the
8008 subshell returns.
8009
8010 =item CPAN::Module::make()
8011
8012 Runs a C<make> on the distribution associated with this module.
8013
8014 =item CPAN::Module::manpage_headline()
8015
8016 If module is installed, peeks into the module's manpage, reads the
8017 headline and returns it. Moreover, if the module has been downloaded
8018 within this session, does the equivalent on the downloaded module even
8019 if it is not installed.
8020
8021 =item CPAN::Module::perldoc()
8022
8023 Runs a C<perldoc> on this module.
8024
8025 =item CPAN::Module::readme()
8026
8027 Runs a C<readme> on the distribution associated with this module.
8028
8029 =item CPAN::Module::test()
8030
8031 Runs a C<test> on the distribution associated with this module.
8032
8033 =item CPAN::Module::uptodate()
8034
8035 Returns 1 if the module is installed and up-to-date.
8036
8037 =item CPAN::Module::userid()
8038
8039 Returns the author's ID of the module.
8040
8041 =back
8042
8043 =head2 Cache Manager
8044
8045 Currently the cache manager only keeps track of the build directory
8046 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
8047 deletes complete directories below C<build_dir> as soon as the size of
8048 all directories there gets bigger than $CPAN::Config->{build_cache}
8049 (in MB). The contents of this cache may be used for later
8050 re-installations that you intend to do manually, but will never be
8051 trusted by CPAN itself. This is due to the fact that the user might
8052 use these directories for building modules on different architectures.
8053
8054 There is another directory ($CPAN::Config->{keep_source_where}) where
8055 the original distribution files are kept. This directory is not
8056 covered by the cache manager and must be controlled by the user. If
8057 you choose to have the same directory as build_dir and as
8058 keep_source_where directory, then your sources will be deleted with
8059 the same fifo mechanism.
8060
8061 =head2 Bundles
8062
8063 A bundle is just a perl module in the namespace Bundle:: that does not
8064 define any functions or methods. It usually only contains documentation.
8065
8066 It starts like a perl module with a package declaration and a $VERSION
8067 variable. After that the pod section looks like any other pod with the
8068 only difference being that I<one special pod section> exists starting with
8069 (verbatim):
8070
8071         =head1 CONTENTS
8072
8073 In this pod section each line obeys the format
8074
8075         Module_Name [Version_String] [- optional text]
8076
8077 The only required part is the first field, the name of a module
8078 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
8079 of the line is optional. The comment part is delimited by a dash just
8080 as in the man page header.
8081
8082 The distribution of a bundle should follow the same convention as
8083 other distributions.
8084
8085 Bundles are treated specially in the CPAN package. If you say 'install
8086 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
8087 the modules in the CONTENTS section of the pod. You can install your
8088 own Bundles locally by placing a conformant Bundle file somewhere into
8089 your @INC path. The autobundle() command which is available in the
8090 shell interface does that for you by including all currently installed
8091 modules in a snapshot bundle file.
8092
8093 =head1 PREREQUISITES
8094
8095 If you have a local mirror of CPAN and can access all files with
8096 "file:" URLs, then you only need a perl better than perl5.003 to run
8097 this module. Otherwise Net::FTP is strongly recommended. LWP may be
8098 required for non-UNIX systems or if your nearest CPAN site is
8099 associated with a URL that is not C<ftp:>.
8100
8101 If you have neither Net::FTP nor LWP, there is a fallback mechanism
8102 implemented for an external ftp command or for an external lynx
8103 command.
8104
8105 =head1 UTILITIES
8106
8107 =head2 Finding packages and VERSION
8108
8109 This module presumes that all packages on CPAN
8110
8111 =over 2
8112
8113 =item *
8114
8115 declare their $VERSION variable in an easy to parse manner. This
8116 prerequisite can hardly be relaxed because it consumes far too much
8117 memory to load all packages into the running program just to determine
8118 the $VERSION variable. Currently all programs that are dealing with
8119 version use something like this
8120
8121     perl -MExtUtils::MakeMaker -le \
8122         'print MM->parse_version(shift)' filename
8123
8124 If you are author of a package and wonder if your $VERSION can be
8125 parsed, please try the above method.
8126
8127 =item *
8128
8129 come as compressed or gzipped tarfiles or as zip files and contain a
8130 C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
8131 without much enthusiasm).
8132
8133 =back
8134
8135 =head2 Debugging
8136
8137 The debugging of this module is a bit complex, because we have
8138 interferences of the software producing the indices on CPAN, of the
8139 mirroring process on CPAN, of packaging, of configuration, of
8140 synchronicity, and of bugs within CPAN.pm.
8141
8142 For code debugging in interactive mode you can try "o debug" which
8143 will list options for debugging the various parts of the code. You
8144 should know that "o debug" has built-in completion support.
8145
8146 For data debugging there is the C<dump> command which takes the same
8147 arguments as make/test/install and outputs the object's Data::Dumper
8148 dump.
8149
8150 =head2 Floppy, Zip, Offline Mode
8151
8152 CPAN.pm works nicely without network too. If you maintain machines
8153 that are not networked at all, you should consider working with file:
8154 URLs. Of course, you have to collect your modules somewhere first. So
8155 you might use CPAN.pm to put together all you need on a networked
8156 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
8157 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
8158 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
8159 with this floppy. See also below the paragraph about CD-ROM support.
8160
8161 =head2 Basic Utilities for Programmers
8162
8163 =over 2
8164
8165 =item has_inst($module)
8166
8167 Returns true if the module is installed. See the source for details.
8168
8169 =item has_usable($module)
8170
8171 Returns true if the module is installed and several and is in a usable
8172 state. Only useful for a handful of modules that are used internally.
8173 See the source for details.
8174
8175 =item instance($module)
8176
8177 The constructor for all the singletons used to represent modules,
8178 distributions, authors and bundles. If the object already exists, this
8179 method returns the object, otherwise it calls the constructor.
8180
8181 =back
8182
8183 =head1 CONFIGURATION
8184
8185 When the CPAN module is used for the first time, a configuration
8186 dialog tries to determine a couple of site specific options. The
8187 result of the dialog is stored in a hash reference C< $CPAN::Config >
8188 in a file CPAN/Config.pm.
8189
8190 The default values defined in the CPAN/Config.pm file can be
8191 overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
8192 best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
8193 added to the search path of the CPAN module before the use() or
8194 require() statements.
8195
8196 The configuration dialog can be started any time later again by
8197 issuing the command C< o conf init > in the CPAN shell. A subset of
8198 the configuration dialog can be run by issuing C<o conf init WORD>
8199 where WORD is any valid config variable or a regular expression.
8200
8201 Currently the following keys in the hash reference $CPAN::Config are
8202 defined:
8203
8204   build_cache        size of cache for directories to build modules
8205   build_dir          locally accessible directory to build modules
8206   build_requires_install_policy
8207                      to install or not to install: when a module is
8208                      only needed for building. yes|no|ask/yes|ask/no
8209   bzip2              path to external prg
8210   cache_metadata     use serializer to cache metadata
8211   commands_quote     prefered character to use for quoting external
8212                      commands when running them. Defaults to double
8213                      quote on Windows, single tick everywhere else;
8214                      can be set to space to disable quoting
8215   check_sigs         if signatures should be verified
8216   colorize_output    boolean if Term::ANSIColor should colorize output
8217   colorize_print     Term::ANSIColor attributes for normal output
8218   colorize_warn      Term::ANSIColor attributes for warnings
8219   commandnumber_in_prompt
8220                      boolean if you want to see current command number
8221   cpan_home          local directory reserved for this package
8222   curl               path to external prg
8223   dontload_hash      DEPRECATED
8224   dontload_list      arrayref: modules in the list will not be
8225                      loaded by the CPAN::has_inst() routine
8226   ftp                path to external prg
8227   ftp_passive        if set, the envariable FTP_PASSIVE is set for downloads
8228   ftp_proxy          proxy host for ftp requests
8229   getcwd             see below
8230   gpg                path to external prg
8231   gzip               location of external program gzip
8232   histfile           file to maintain history between sessions
8233   histsize           maximum number of lines to keep in histfile
8234   http_proxy         proxy host for http requests
8235   inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
8236                      after this many seconds inactivity. Set to 0 to
8237                      never break.
8238   index_expire       after this many days refetch index files
8239   inhibit_startup_message
8240                      if true, does not print the startup message
8241   keep_source_where  directory in which to keep the source (if we do)
8242   lynx               path to external prg
8243   make               location of external make program
8244   make_arg           arguments that should always be passed to 'make'
8245   make_install_make_command
8246                      the make command for running 'make install', for
8247                      example 'sudo make'
8248   make_install_arg   same as make_arg for 'make install'
8249   makepl_arg         arguments passed to 'perl Makefile.PL'
8250   mbuild_arg         arguments passed to './Build'
8251   mbuild_install_arg arguments passed to './Build install'
8252   mbuild_install_build_command
8253                      command to use instead of './Build' when we are
8254                      in the install stage, for example 'sudo ./Build'
8255   mbuildpl_arg       arguments passed to 'perl Build.PL'
8256   ncftp              path to external prg
8257   ncftpget           path to external prg
8258   no_proxy           don't proxy to these hosts/domains (comma separated list)
8259   pager              location of external program more (or any pager)
8260   password           your password if you CPAN server wants one
8261   prefer_installer   legal values are MB and EUMM: if a module comes
8262                      with both a Makefile.PL and a Build.PL, use the
8263                      former (EUMM) or the latter (MB); if the module
8264                      comes with only one of the two, that one will be
8265                      used in any case
8266   prerequisites_policy
8267                      what to do if you are missing module prerequisites
8268                      ('follow' automatically, 'ask' me, or 'ignore')
8269   proxy_user         username for accessing an authenticating proxy
8270   proxy_pass         password for accessing an authenticating proxy
8271   scan_cache         controls scanning of cache ('atstart' or 'never')
8272   shell              your favorite shell
8273   show_upload_date   boolean if commands should try to determine upload date
8274   tar                location of external program tar
8275   term_is_latin      if true internal UTF-8 is translated to ISO-8859-1
8276                      (and nonsense for characters outside latin range)
8277   term_ornaments     boolean to turn ReadLine ornamenting on/off
8278   test_report        email test reports (if CPAN::Reporter is installed)
8279   unzip              location of external program unzip
8280   urllist            arrayref to nearby CPAN sites (or equivalent locations)
8281   username           your username if you CPAN server wants one
8282   wait_list          arrayref to a wait server to try (See CPAN::WAIT)
8283   wget               path to external prg
8284
8285 You can set and query each of these options interactively in the cpan
8286 shell with the command set defined within the C<o conf> command:
8287
8288 =over 2
8289
8290 =item C<o conf E<lt>scalar optionE<gt>>
8291
8292 prints the current value of the I<scalar option>
8293
8294 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
8295
8296 Sets the value of the I<scalar option> to I<value>
8297
8298 =item C<o conf E<lt>list optionE<gt>>
8299
8300 prints the current value of the I<list option> in MakeMaker's
8301 neatvalue format.
8302
8303 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
8304
8305 shifts or pops the array in the I<list option> variable
8306
8307 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
8308
8309 works like the corresponding perl commands.
8310
8311 =back
8312
8313 =head2 CPAN::anycwd($path): Note on config variable getcwd
8314
8315 CPAN.pm changes the current working directory often and needs to
8316 determine its own current working directory. Per default it uses
8317 Cwd::cwd but if this doesn't work on your system for some reason,
8318 alternatives can be configured according to the following table:
8319
8320 =over 2
8321
8322 =item cwd
8323
8324 Calls Cwd::cwd
8325
8326 =item getcwd
8327
8328 Calls Cwd::getcwd
8329
8330 =item fastcwd
8331
8332 Calls Cwd::fastcwd
8333
8334 =item backtickcwd
8335
8336 Calls the external command cwd.
8337
8338 =back
8339
8340 =head2 Note on urllist parameter's format
8341
8342 urllist parameters are URLs according to RFC 1738. We do a little
8343 guessing if your URL is not compliant, but if you have problems with
8344 file URLs, please try the correct format. Either:
8345
8346     file://localhost/whatever/ftp/pub/CPAN/
8347
8348 or
8349
8350     file:///home/ftp/pub/CPAN/
8351
8352 =head2 urllist parameter has CD-ROM support
8353
8354 The C<urllist> parameter of the configuration table contains a list of
8355 URLs that are to be used for downloading. If the list contains any
8356 C<file> URLs, CPAN always tries to get files from there first. This
8357 feature is disabled for index files. So the recommendation for the
8358 owner of a CD-ROM with CPAN contents is: include your local, possibly
8359 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
8360
8361   o conf urllist push file://localhost/CDROM/CPAN
8362
8363 CPAN.pm will then fetch the index files from one of the CPAN sites
8364 that come at the beginning of urllist. It will later check for each
8365 module if there is a local copy of the most recent version.
8366
8367 Another peculiarity of urllist is that the site that we could
8368 successfully fetch the last file from automatically gets a preference
8369 token and is tried as the first site for the next request. So if you
8370 add a new site at runtime it may happen that the previously preferred
8371 site will be tried another time. This means that if you want to disallow
8372 a site for the next transfer, it must be explicitly removed from
8373 urllist.
8374
8375 =head1 SECURITY
8376
8377 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
8378 install foreign, unmasked, unsigned code on your machine. We compare
8379 to a checksum that comes from the net just as the distribution file
8380 itself. But we try to make it easy to add security on demand:
8381
8382 =head2 Cryptographically signed modules
8383
8384 Since release 1.77 CPAN.pm has been able to verify cryptographically
8385 signed module distributions using Module::Signature.  The CPAN modules
8386 can be signed by their authors, thus giving more security.  The simple
8387 unsigned MD5 checksums that were used before by CPAN protect mainly
8388 against accidental file corruption.
8389
8390 You will need to have Module::Signature installed, which in turn
8391 requires that you have at least one of Crypt::OpenPGP module or the
8392 command-line F<gpg> tool installed.
8393
8394 You will also need to be able to connect over the Internet to the public
8395 keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
8396
8397 The configuration parameter check_sigs is there to turn signature
8398 checking on or off.
8399
8400 =head1 EXPORT
8401
8402 Most functions in package CPAN are exported per default. The reason
8403 for this is that the primary use is intended for the cpan shell or for
8404 one-liners.
8405
8406 =head1 ENVIRONMENT
8407
8408 When the CPAN shell enters a subshell via the look command, it sets
8409 the environment CPAN_SHELL_LEVEL to 1 or increments it if it is
8410 already set.
8411
8412 When the config variable ftp_passive is set, all downloads will be run
8413 with the environment variable FTP_PASSIVE set to this value. This is
8414 in general a good idea as it influences both Net::FTP and LWP based
8415 connections. The same effect can be achieved by starting the cpan
8416 shell with this environment variable set. For Net::FTP alone, one can
8417 also always set passive mode by running libnetcfg.
8418
8419 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
8420
8421 Populating a freshly installed perl with my favorite modules is pretty
8422 easy if you maintain a private bundle definition file. To get a useful
8423 blueprint of a bundle definition file, the command autobundle can be used
8424 on the CPAN shell command line. This command writes a bundle definition
8425 file for all modules that are installed for the currently running perl
8426 interpreter. It's recommended to run this command only once and from then
8427 on maintain the file manually under a private name, say
8428 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
8429
8430     cpan> install Bundle::my_bundle
8431
8432 then answer a few questions and then go out for a coffee.
8433
8434 Maintaining a bundle definition file means keeping track of two
8435 things: dependencies and interactivity. CPAN.pm sometimes fails on
8436 calculating dependencies because not all modules define all MakeMaker
8437 attributes correctly, so a bundle definition file should specify
8438 prerequisites as early as possible. On the other hand, it's a bit
8439 annoying that many distributions need some interactive configuring. So
8440 what I try to accomplish in my private bundle file is to have the
8441 packages that need to be configured early in the file and the gentle
8442 ones later, so I can go out after a few minutes and leave CPAN.pm
8443 untended.
8444
8445 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
8446
8447 Thanks to Graham Barr for contributing the following paragraphs about
8448 the interaction between perl, and various firewall configurations. For
8449 further information on firewalls, it is recommended to consult the
8450 documentation that comes with the ncftp program. If you are unable to
8451 go through the firewall with a simple Perl setup, it is very likely
8452 that you can configure ncftp so that it works for your firewall.
8453
8454 =head2 Three basic types of firewalls
8455
8456 Firewalls can be categorized into three basic types.
8457
8458 =over 4
8459
8460 =item http firewall
8461
8462 This is where the firewall machine runs a web server and to access the
8463 outside world you must do it via the web server. If you set environment
8464 variables like http_proxy or ftp_proxy to a values beginning with http://
8465 or in your web browser you have to set proxy information then you know
8466 you are running an http firewall.
8467
8468 To access servers outside these types of firewalls with perl (even for
8469 ftp) you will need to use LWP.
8470
8471 =item ftp firewall
8472
8473 This where the firewall machine runs an ftp server. This kind of
8474 firewall will only let you access ftp servers outside the firewall.
8475 This is usually done by connecting to the firewall with ftp, then
8476 entering a username like "user@outside.host.com"
8477
8478 To access servers outside these type of firewalls with perl you
8479 will need to use Net::FTP.
8480
8481 =item One way visibility
8482
8483 I say one way visibility as these firewalls try to make themselves look
8484 invisible to the users inside the firewall. An FTP data connection is
8485 normally created by sending the remote server your IP address and then
8486 listening for the connection. But the remote server will not be able to
8487 connect to you because of the firewall. So for these types of firewall
8488 FTP connections need to be done in a passive mode.
8489
8490 There are two that I can think off.
8491
8492 =over 4
8493
8494 =item SOCKS
8495
8496 If you are using a SOCKS firewall you will need to compile perl and link
8497 it with the SOCKS library, this is what is normally called a 'socksified'
8498 perl. With this executable you will be able to connect to servers outside
8499 the firewall as if it is not there.
8500
8501 =item IP Masquerade
8502
8503 This is the firewall implemented in the Linux kernel, it allows you to
8504 hide a complete network behind one IP address. With this firewall no
8505 special compiling is needed as you can access hosts directly.
8506
8507 For accessing ftp servers behind such firewalls you usually need to
8508 set the environment variable C<FTP_PASSIVE> or the config variable
8509 ftp_passive to a true value.
8510
8511 =back
8512
8513 =back
8514
8515 =head2 Configuring lynx or ncftp for going through a firewall
8516
8517 If you can go through your firewall with e.g. lynx, presumably with a
8518 command such as
8519
8520     /usr/local/bin/lynx -pscott:tiger
8521
8522 then you would configure CPAN.pm with the command
8523
8524     o conf lynx "/usr/local/bin/lynx -pscott:tiger"
8525
8526 That's all. Similarly for ncftp or ftp, you would configure something
8527 like
8528
8529     o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
8530
8531 Your mileage may vary...
8532
8533 =head1 FAQ
8534
8535 =over 4
8536
8537 =item 1)
8538
8539 I installed a new version of module X but CPAN keeps saying,
8540 I have the old version installed
8541
8542 Most probably you B<do> have the old version installed. This can
8543 happen if a module installs itself into a different directory in the
8544 @INC path than it was previously installed. This is not really a
8545 CPAN.pm problem, you would have the same problem when installing the
8546 module manually. The easiest way to prevent this behaviour is to add
8547 the argument C<UNINST=1> to the C<make install> call, and that is why
8548 many people add this argument permanently by configuring
8549
8550   o conf make_install_arg UNINST=1
8551
8552 =item 2)
8553
8554 So why is UNINST=1 not the default?
8555
8556 Because there are people who have their precise expectations about who
8557 may install where in the @INC path and who uses which @INC array. In
8558 fine tuned environments C<UNINST=1> can cause damage.
8559
8560 =item 3)
8561
8562 I want to clean up my mess, and install a new perl along with
8563 all modules I have. How do I go about it?
8564
8565 Run the autobundle command for your old perl and optionally rename the
8566 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
8567 with the Configure option prefix, e.g.
8568
8569     ./Configure -Dprefix=/usr/local/perl-5.6.78.9
8570
8571 Install the bundle file you produced in the first step with something like
8572
8573     cpan> install Bundle::mybundle
8574
8575 and you're done.
8576
8577 =item 4)
8578
8579 When I install bundles or multiple modules with one command
8580 there is too much output to keep track of.
8581
8582 You may want to configure something like
8583
8584   o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
8585   o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
8586
8587 so that STDOUT is captured in a file for later inspection.
8588
8589
8590 =item 5)
8591
8592 I am not root, how can I install a module in a personal directory?
8593
8594 First of all, you will want to use your own configuration, not the one
8595 that your root user installed. If you do not have permission to write
8596 in the cpan directory that root has configured, you will be asked if
8597 you want to create your own config. Answering "yes" will bring you into
8598 CPAN's configuration stage, using the system config for all defaults except
8599 things that have to do with CPAN's work directory, saving your choices to
8600 your MyConfig.pm file.
8601
8602 You can also manually initiate this process with the following command:
8603
8604     % perl -MCPAN -e 'mkmyconfig'
8605
8606 or by running
8607
8608     mkmyconfig
8609
8610 from the CPAN shell.
8611
8612 You will most probably also want to configure something like this:
8613
8614   o conf makepl_arg "LIB=~/myperl/lib \
8615                     INSTALLMAN1DIR=~/myperl/man/man1 \
8616                     INSTALLMAN3DIR=~/myperl/man/man3"
8617
8618 You can make this setting permanent like all C<o conf> settings with
8619 C<o conf commit>.
8620
8621 You will have to add ~/myperl/man to the MANPATH environment variable
8622 and also tell your perl programs to look into ~/myperl/lib, e.g. by
8623 including
8624
8625   use lib "$ENV{HOME}/myperl/lib";
8626
8627 or setting the PERL5LIB environment variable.
8628
8629 While we're speaking about $ENV{HOME}, it might be worth mentioning,
8630 that for Windows we use the File::HomeDir module that provides an
8631 equivalent to the concept of the home directory on Unix.
8632
8633 Another thing you should bear in mind is that the UNINST parameter can
8634 be dnagerous when you are installing into a private area because you
8635 might accidentally remove modules that other people depend on that are
8636 not using the private area.
8637
8638 =item 6)
8639
8640 How to get a package, unwrap it, and make a change before building it?
8641
8642 Have a look at the C<look> (!) command.
8643
8644 =item 7)
8645
8646 I installed a Bundle and had a couple of fails. When I
8647 retried, everything resolved nicely. Can this be fixed to work
8648 on first try?
8649
8650 The reason for this is that CPAN does not know the dependencies of all
8651 modules when it starts out. To decide about the additional items to
8652 install, it just uses data found in the META.yml file or the generated
8653 Makefile. An undetected missing piece breaks the process. But it may
8654 well be that your Bundle installs some prerequisite later than some
8655 depending item and thus your second try is able to resolve everything.
8656 Please note, CPAN.pm does not know the dependency tree in advance and
8657 cannot sort the queue of things to install in a topologically correct
8658 order. It resolves perfectly well IF all modules declare the
8659 prerequisites correctly with the PREREQ_PM attribute to MakeMaker or
8660 the C<requires> stanza of Module::Build. For bundles which fail and
8661 you need to install often, it is recommended to sort the Bundle
8662 definition file manually.
8663
8664 =item 8)
8665
8666 In our intranet we have many modules for internal use. How
8667 can I integrate these modules with CPAN.pm but without uploading
8668 the modules to CPAN?
8669
8670 Have a look at the CPAN::Site module.
8671
8672 =item 9)
8673
8674 When I run CPAN's shell, I get an error message about things in my
8675 /etc/inputrc (or ~/.inputrc) file.
8676
8677 These are readline issues and can only be fixed by studying readline
8678 configuration on your architecture and adjusting the referenced file
8679 accordingly. Please make a backup of the /etc/inputrc or ~/.inputrc
8680 and edit them. Quite often harmless changes like uppercasing or
8681 lowercasing some arguments solves the problem.
8682
8683 =item 10)
8684
8685 Some authors have strange characters in their names.
8686
8687 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
8688 expecting ISO-8859-1 charset, a converter can be activated by setting
8689 term_is_latin to a true value in your config file. One way of doing so
8690 would be
8691
8692     cpan> o conf term_is_latin 1
8693
8694 If other charset support is needed, please file a bugreport against
8695 CPAN.pm at rt.cpan.org and describe your needs. Maybe we can extend
8696 the support or maybe UTF-8 terminals become widely available.
8697
8698 =item 11)
8699
8700 When an install fails for some reason and then I correct the error
8701 condition and retry, CPAN.pm refuses to install the module, saying
8702 C<Already tried without success>.
8703
8704 Use the force pragma like so
8705
8706   force install Foo::Bar
8707
8708 This does a bit more than really needed because it untars the
8709 distribution again and runs make and test and only then install.
8710
8711 Or, if you find this is too fast and you would prefer to do smaller
8712 steps, say
8713
8714   force get Foo::Bar
8715
8716 first and then continue as always. C<Force get> I<forgets> previous
8717 error conditions.
8718
8719 Or you can use
8720
8721   look Foo::Bar
8722
8723 and then 'make install' directly in the subshell.
8724
8725 Or you leave the CPAN shell and start it again.
8726
8727 For the really curious, by accessing internals directly, you I<could>
8728
8729   !delete CPAN::Shell->expandany("Foo::Bar")->distribution->{install}
8730
8731 but this is neither guaranteed to work in the future nor is it a
8732 decent command.
8733
8734 =item 12)
8735
8736 How do I install a "DEVELOPER RELEASE" of a module?
8737
8738 By default, CPAN will install the latest non-developer release of a
8739 module. If you want to install a dev release, you have to specify the
8740 partial path starting with the author id to the tarball you wish to
8741 install, like so:
8742
8743     cpan> install KWILLIAMS/Module-Build-0.27_07.tar.gz
8744
8745 Note that you can use the C<ls> command to get this path listed.
8746
8747 =item 13)
8748
8749 How do I install a module and all its dependencies from the commandline,
8750 without being prompted for anything, despite my CPAN configuration
8751 (or lack thereof)?
8752
8753 CPAN uses ExtUtils::MakeMaker's prompt() function to ask its questions, so
8754 if you set the PERL_MM_USE_DEFAULT environment variable, you shouldn't be
8755 asked any questions at all (assuming the modules you are installing are
8756 nice about obeying that variable as well):
8757
8758     % PERL_MM_USE_DEFAULT=1 perl -MCPAN -e 'install My::Module'
8759
8760 =item 14)
8761
8762 How do I create a Module::Build based Build.PL derived from an
8763 ExtUtils::MakeMaker focused Makefile.PL?
8764
8765 http://search.cpan.org/search?query=Module::Build::Convert
8766
8767 http://accognoscere.org/papers/perl-module-build-convert/module-build-convert.html
8768
8769
8770 =back
8771
8772 =head1 BUGS
8773
8774 Please report bugs via http://rt.cpan.org/
8775
8776 Before submitting a bug, please make sure that the traditional method
8777 of building a Perl module package from a shell by following the
8778 installation instructions of that package still works in your
8779 environment.
8780
8781 =head1 SECURITY ADVICE
8782
8783 This software enables you to upgrade software on your computer and so
8784 is inherently dangerous because the newly installed software may
8785 contain bugs and may alter the way your computer works or even make it
8786 unusable. Please consider backing up your data before every upgrade.
8787
8788 =head1 AUTHOR
8789
8790 Andreas Koenig C<< <andk@cpan.org> >>
8791
8792 =head1 LICENSE
8793
8794 This program is free software; you can redistribute it and/or
8795 modify it under the same terms as Perl itself.
8796
8797 See L<http://www.perl.com/perl/misc/Artistic.html>
8798
8799 =head1 TRANSLATIONS
8800
8801 Kawai,Takanori provides a Japanese translation of this manpage at
8802 http://member.nifty.ne.jp/hippo2000/perltips/CPAN.htm
8803
8804 =head1 SEE ALSO
8805
8806 cpan(1), CPAN::Nox(3pm), CPAN::Version(3pm)
8807
8808 =cut